Arc Forumnew | comments | leaders | submitlogin
Cleaner version of 'ac.scm' using xcar and some other cleanups
7 points by vincenz 6129 days ago | 4 comments
Here's a slight clean up of 'ac'

    (define (ac s env)
      (let ((head (xcar s)))
        (cond ((string? s) (string-copy s))  ; to avoid immutable strings
              ((literal? s) s)
              ((eqv? s 'nil) (list 'quote 'nil))
              ((ssyntax? s) (ac (expand-ssyntax s) env))
              ((symbol? s) (ac-var-ref s env))
              ((ssyntax? head) (ac (cons (expand-ssyntax head) (cdr s)) env))
              ((eq? head 'quote) (list 'quote (ac-niltree (cadr s))))
              ((eq? head 'quasiquote) (ac-qq (cadr s) env))
              ((eq? head 'if) (ac-if (cdr s) env))
              ((eq? head 'fn) (ac-fn (cadr s) (cddr s) env))
              ((eq? head 'set) (ac-set (cdr s) env))
              ; this line could be removed without changing semantics
              ((eq? (xcar head) 'compose) (ac (decompose (cdar s) (cdr s)) env))
              ((pair? s) (ac-call (car s) (cdr s) env))
              (#t (err "Bad object in expression" s)))))


4 points by vincenz 6129 days ago | link

Finally, a big clean for 'ac-call'

    (define (ac-call fn args env)
      (let ((macfn (ac-macro? fn)))
        (if macfn
          (ac-mac-call macfn args env)
          (let ((afn (ac fn env))
                (aargs (map (lambda (x) (ac x env)) args))
                (nargs (length args)))
            (cond 
              ((eqv? (xcar fn) 'fn)
               `(,afn ,@aargs))
              ((and (>= nargs 0) (<= nargs 4))
               `(,(string->symbol (string-append "ar-funcall" (number->string nargs)))
                                  ,afn ,@aargs))
               (#t
                `(ar-apply ,afn (list ,@aargs))))))))

-----

3 points by vincenz 6129 days ago | link

Idem for 'ac-qq1'

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

-----

4 points by vincenz 6129 days ago | link

Idem for 'ac-macex' and cleaning up some more

    (define (ac-macex e . once)
      (let ((m (ac-macro? (xcar e))))
        (if m
          (let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
            (if (null? once) (ac-macex expansion) expansion))
          e))
      )

-----

3 points by vincenz 6129 days ago | link

Idem for 'ac-complex-args?'

    (define (ac-complex-args? args)
      (cond ((eqv? args '()) #f)
            ((symbol? args) #f)
            ((symbol? (xcar args))
             (ac-complex-args? (cdr args)))
            (#t #t)))

-----