Bare-bones implementation to compile def and mac and list (http://arclanguage.org/item?id=12057).

ac.scm

(define (ac s env)
  (cond ((string? s) (ac-string s env))
        ((literal? s) s)
        ((eqv? s 'nil) (list 'quote '()))
        ((symbol? s) (ac-var-ref s env))
        ((eq? (xcar s) 'quote) (list 'quote (cadr s)))
        ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
        ((eq? (xcar s) 'if) (ac-if (cdr s) env))
        ((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
        ((eq? (xcar s) 'assign) (ac-set (cdr s) env))
        ((pair? s) (ac-call (car s) (cdr s) env))
        (#t (error "Bad object in expression" s))))

(define (ac-string s env)
  (string-copy s))

(define (literal? x)
  (or (boolean? x)
      (char? x)
      (string? x)
      (number? x)
      (eq? x '())))

(define (ac-global-name s)
  (string->symbol (string-append "_" (symbol->string s))))

 (define (ac-var-ref s env)
  (cond ((lex? s env)        s)
        (#t                  (ac-global-name s))))

(define (ac-qq args env)
  (list 'quasiquote (ac-qq1 1 args env)))

(define (ac-qq1 level x env)
  (cond ((= level 0)
         (ac x env))
        ((and (pair? x) (eqv? (car x) 'unquote))
         (list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
        ((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
         (list 'unquote-splicing
               (ac-qq1 (- level 1) (cadr x) env)))
        ((and (pair? x) (eqv? (car x) 'quasiquote))
         (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
        ((pair? x)
         (map (lambda (x) (ac-qq1 level x env)) x))
        (#t x)))

(define (ac-if args env)
  (cond ((null? args) '())
        ((null? (cdr args)) (ac (car args) env))
        (#t `(if (not (ar-false? ,(ac (car args) env)))
                 ,(ac (cadr args) env)
                 ,(ac-if (cddr args) env)))))

(define (ac-fn args body env)
   `(lambda ,(let ((a args)) (if (eqv? a '()) '() a))
      ,@(ac-body* body (append (ac-arglist args) env))))

(define (ac-arglist a)
  (cond ((null? a) '())
        ((symbol? a) (list a))
        ((symbol? (cdr a)) (list (car a) (cdr a)))
        (#t (cons (car a) (ac-arglist (cdr a))))))

(define (ac-body body env)
  (map (lambda (x) (ac x env)) body))

(define (ac-body* body env)
  (if (null? body)
      (list (list 'quote '()))
      (ac-body body env)))

(define (ac-set x env)
  `(begin ,@(ac-setn x env)))

(define (ac-setn x env)
  (if (null? x)
      '()
      (cons (ac-set1 (ac-macex (car x)) (cadr x) env)
            (ac-setn (cddr x) env))))

(define (ac-set1 a b1 env)
  (if (symbol? a)
      (let ((b (ac b1 (ac-dbname! a env))))
        (list 'let `((zz ,b))
               (cond ((eqv? a '()) (error "Can't rebind nil"))
                     ((eqv? a 't) (error "Can't rebind t"))
                     ((lex? a env) `(set! ,a zz))
                     (#t `(namespace-set-variable-value! ',(ac-global-name a)
                                                         zz)))
               'zz))
      (error "First arg to set must be a symbol" a)))

(define (ac-dbname! name env)
  (if (symbol? name)
      (cons (list name) env)
      env))

(define (ac-args names exprs env)
  (if (null? exprs)
      '()
      (cons (ac (car exprs)
                (ac-dbname! (if (pair? names) (car names) #f) env))
            (ac-args (if (pair? names) (cdr names) '())
                     (cdr exprs)
                     env))))

(define (ac-global-call fn args env)
 `(,(ac-global-name fn) ,@(ac-args '() args env)))

(define (ac-call fn args env)
  (let ((macfn (ac-macro? fn)))
    (cond (macfn
           (ac-mac-call macfn args env))
          ((and (pair? fn) (eqv? (car fn) 'fn))
           `(,(ac fn env) ,@(ac-args (cadr fn) args env)))
          (#t
           `(ar-apply ,(ac fn env)
                      (list ,@(map (lambda (x) (ac x env)) args)))))))

(define (ac-mac-call m args env)
  (let ((x1 (apply m args)))
    (let ((x2 (ac x1 env)))
      x2)))

(define (ac-macro? fn)
  (if (symbol? fn)
      (let ((v (namespace-variable-value (ac-global-name fn)
                                         #t
                                         (lambda () #f))))
        (if (and v
                 (ar-tagged? v)
                 (eq? (ar-type v) 'mac))
            (ar-rep v)
            #f))
      #f))

(define (ac-macex e . once)
  (if (pair? e)
      (let ((m (ac-macro? (car e))))
        (if m
            (let ((expansion (apply m (cdr e))))
              (if (null? once) (ac-macex expansion) expansion))
            e))
      e))

(define (lex? v env)
  (memq v env))

(define (xcar x)
  (and (pair? x) (car x)))

(define-syntax xdef
  (syntax-rules ()
    ((xxdef a b)
     (let ((nm (ac-global-name 'a))
           (a b))
       (namespace-set-variable-value! nm a)
       a))))

(define (ar-xcar x)
  (if (null? x)
      '()
      (car x)))

(define (ar-xcdr x)
  (if (null? x)
      '()
      (cdr x)))

(define (ar-nill x)
  (if (or (eq? x '()) (eq? x #f))
      '()
      x))

(define (ar-false? x)
  (or (null? x) (eq? x #f)))

(define (ar-apply fn args)
  (cond ((procedure? fn)
         (apply fn args))
        ((pair? fn)
         (list-ref fn (car args)))
        ((string? fn)
         (string-ref fn (car args)))
        ((hash-table? fn)
         (ar-nill (hash-table-get fn
                                  (car args)
                                  (if (pair? (cdr args)) (cadr args) #f))))
        (#t (error "Function call on inappropriate object" fn args))))

(xdef apply (lambda (fn . args)
               (ar-apply fn (ar-apply-args args))))

(define (ar-apply-args args)
  (cond ((null? args) '())
        ((null? (cdr args)) (car args))
        (#t (cons (car args) (ar-apply-args (cdr args))))))





(xdef cons cons)

(xdef car (lambda (x)
             (cond ((pair? x)     (car x))
                   ((eqv? x '()) '())
                   ((eqv? x '())  '())
                   (#t            (error "Can't take car of" x)))))

(xdef cdr (lambda (x)
             (cond ((pair? x)     (cdr x))
                   ((eqv? x '()) '())
                   ((eqv? x '())  '())
                   (#t            (error "Can't take cdr of" x)))))

(define (ar-tagged? x)
  (and (vector? x) (eq? (vector-ref x 0) 'tagged)))

(define (ar-tag type rep)
  (cond ((eqv? (ar-type rep) type) rep)
        (#t (vector 'tagged type rep))))

(xdef annotate ar-tag)

; (type nil) -> sym

(define (exint? x) (and (integer? x) (exact? x)))

(define (ar-type x)
  (cond ((ar-tagged? x)     (vector-ref x 1))
        ((pair? x)          'cons)
        ((symbol? x)        'sym)
        ((null? x)          'sym)
        ((procedure? x)     'fn)
        ((char? x)          'char)
        ((string? x)        'string)
        ((exint? x)         'int)
        ((number? x)        'num)     ; unsure about this
        ((hash-table? x)    'table)
        ((output-port? x)   'output)
        ((input-port? x)    'input)
        ((tcp-listener? x)  'socket)
        ((exn? x)           'exception)
        ((thread? x)        'thread)
        (#t                 (error "Type: unknown type" x))))

(define (ar-rep x)
  (if (ar-tagged? x)
      (vector-ref x 2)
      x))

(define (ar-coerce x type . args)
  (cond
    ((ar-tagged? x) (error "Can't coerce annotated object"))
    ((eqv? type (ar-type x)) x)
    ((char? x)      (case type
                      ((int)     (char->ascii x))
                      ((string)  (string x))
                      ((sym)     (string->symbol (string x)))
                      ((else)    (error "Can't coerce" x type))))
    ((exint? x)     (case type
                      ((num)     x)
                      ((char)    (ascii->char x))
                      ((string)  (apply number->string x args))
                      ((else)    (error "Can't coerce" x type))))
    ((number? x)    (case type
                      ((int)     (iround x))
                      ((char)    (ascii->char (iround x)))
                      ((string)  (apply number->string x args))
                      ((else)    (error "Can't coerce" x type))))
    ((string? x)    (case type
                      ((sym)     (string->symbol x))
                      ((cons)    (string->list x))
                      ((num)     (or (apply string->number x args)
                                     (error "Can't coerce" x type)))
                      ((int)     (let ((n (apply string->number x args)))
                                   (if n
                                       (iround n)
                                       (error "Can't coerce" x type))))
                      ((else)    (error "Can't coerce" x type))))
    ((pair? x)      (case type
                      ((string)  (apply string-append
                                        (map (lambda (y) (ar-coerce y 'string))
                                             x)))
                      ((else)    (error "Can't coerce" x type))))
    ((eqv? x '())  (case type
                      ((string)  "")
                      ((else)    (error "Can't coerce" x type))))
    ((null? x)      (case type
                      ((string)  "")
                      ((else)    (error "Can't coerce" x type))))
    ((symbol? x)    (case type
                      ((string)  (symbol->string x))
                      ((else)    (error "Can't coerce" x type))))
    (#t             x)))

(define (aload1 p)
  (let ((x (read p)))
    (if (eof-object? x)
        #t
        (begin
          (eval (ac x '()))
          (aload1 p)))))

(define (aload filename)
  (call-with-input-file filename aload1))

arc.arc

(assign def (annotate 'mac
               (fn (name parms . body)
                  `(assign ,name (fn ,parms ,@body)))))

(assign mac (annotate 'mac
              (fn (name parms . body)
               `(assign ,name (annotate 'mac (fn ,parms ,@body))))))

(def no (x) (is x nil))

(def copylist (xs)
  (if (no xs)
      nil
      (cons (car xs) (copylist (cdr xs)))))

(def list args (copylist args))

as.scm

(load "ac.scm")
(aload "arc.arc")