diff options
Diffstat (limited to 'lib/csc/macros.csc')
| -rw-r--r-- | lib/csc/macros.csc | 215 |
1 files changed, 158 insertions, 57 deletions
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc index e78fc72..f0b4d67 100644 --- a/lib/csc/macros.csc +++ b/lib/csc/macros.csc @@ -21,6 +21,18 @@ map-for-each merge) (only (csc ir1) + %call + %call-builtin + %constant + %define-syntax + %if + %lambda + %letrec + %lexical-ref + %lexical-set + %library-define + %library-ref + %sequence define-syntax-name define-syntax-transformer define-syntax? @@ -30,6 +42,7 @@ library-define-expression library-define-ref library-define? + library-ref-library library-ref-name library-ref? make-call @@ -197,21 +210,24 @@ (cons mark (syntax-object-marks expression))))) - (define (add-marks marks expression) - (let loop ((marks marks) - (expression expression)) - (match marks - ('() expression) - ((mark . marks) - (loop marks (add-mark mark expression)))))) + ; It's worth considering a more efficient algorithm. + (define (add-marks ms expression) + (loop for m in ms + with res = expression + unless (loop for m* in (marks res) + if (eqv? m* m) + return #t + finally (return #f)) + do (set! res (add-mark m res)) + finally (return res))) (define (anti-mark expression) (add-mark #f expression)) - (define (decorate marks expression environment) - (add-marks marks (wrap-syntax expression environment))) + (define (decorate ms expression environment) + (add-marks ms (wrap-syntax expression environment))) (define (with-wrap expression parent) @@ -346,7 +362,11 @@ (make-macro-transformer (lambda (syntax env) (syntax-case syntax - ((_ datum) (make-constant (clean-syntax datum))) + ((_ datum) + (let quote-expr ((datum datum)) + (syntax-case datum + ((head . tail) (make-call-builtin 'cons (list (quote-expr head) (quote-expr tail)))) + (_ (make-constant (clean-syntax datum)))))) (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax))))))) @@ -489,12 +509,14 @@ (object object) (bindings (alist->substitutions '()))) (if (< i n-m) - (let ((binding (pattern-bindings ellipsis literals p (syntax-map car object)))) - (and binding - (loop - (+ 1 i) - (syntax-map cdr object) - (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding))))) + (and + (pair? (syntax->expression object)) + (let ((binding (pattern-bindings ellipsis literals p (syntax-map car object)))) + (and binding + (loop + (+ 1 i) + (syntax-map cdr object) + (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding)))))) (let ((bindings* (pattern-bindings ellipsis literals p* object))) (and bindings* (merge bindings bindings*))))) #f))) @@ -537,6 +559,10 @@ ; Can raise key-not-found-error? or ellipsis-out-of-bounds?. (define (ellipsis-lookup substitutions ellipsis-nesting key) + (define keys '()) + (map-for-each (lambda (k v) + (set! keys (cons (marks k) keys))) + substitutions) (let ((n-d-vector (lookup substitutions key))) (if (ellipsis-binding? n-d-vector) (if (= (ellipsis-binding-nesting-level n-d-vector) (vec-length ellipsis-nesting)) @@ -562,6 +588,10 @@ (define (expand-template ellipsis ellipsis-nesting substitutions template) + (define keys '()) + (map-for-each (lambda (k v) + (set! keys (cons (identifier-name k) keys))) + substitutions) (syntax-case template ('() (with-wrap '() template)) ((head ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) @@ -598,7 +628,8 @@ (expand-template ellipsis ellipsis-nesting substitutions tail)) template)) (ident when (identifier? ident) - (guard (e ((key-not-found-error? e) template)) + (guard (e ((key-not-found-error? e) + template)) (ellipsis-lookup substitutions ellipsis-nesting template))) (_ template))) @@ -659,34 +690,87 @@ (make-macro-transformer (lambda (x env) (syntax-case x - ((_ (ident transformer-form) body-form) when (identifier? ident) - (let* ((transformer (expand transformer-form env)) - (body (expand body-form (add-binding ident transformer env)))) - body)) + ((_ bindings body-form) + (loop with env* = env + for bindings* = bindings + then (syntax-case bindings* + ((_) + (return (expand body-form env*))) + ((_ . rest) rest) + (_ (raise-syntax-error "unexpected form in let-syntax loop" (clean-syntax x)))) + do (syntax-case bindings* + (((ident transformer-form) . _) when (identifier? ident) + (set! env* (add-binding ident (expand transformer-form env) env*))) + (_ (raise-syntax-error "unexpected form in let-syntax binding" (clean-syntax x)))))) (_ (raise-syntax-error "unexpected form in let-syntax" (clean-syntax x))))))) (define (expand-lambda-body-rest body env) - (let loop ((body body) - (expanded-body (make-constant #f))) - (syntax-case body - ('() - expanded-body) - ((expr . expr*) - (define expanded-expr (expand expr env)) - (when (or (library-define? expanded-expr) - (define-syntax? expanded-expr)) - (raise-syntax-error "define not allowed here" body)) - (loop (syntax-map cdr body) - (make-sequence expanded-body expanded-expr)))))) + (syntax-case body + ('() (make-constant #f)) + (_ (loop for body* = body then (syntax-map cdr body*) + for expanded-expr = (expand (syntax-map car body*) env) + for expanded-body = expanded-expr then (make-sequence expanded-body expanded-expr) + finally (return expanded-body) + when (or (library-define? expanded-expr) + (define-syntax? expanded-expr)) + do (raise-syntax-error "define not allowed here" body) + until (syntax-case body* + ((_) #t) + (_ #f)))))) + + + (define (library-ref->string r) + (sprintf "{}" (list (library-ref-name r) (library-ref-library r)))) + + + (define compare-library-refs + (make-comparer + (lambda (r) + (hash-bytevector (string->utf8 (library-ref->string r)))) + (lambda (r1 r2) + (cond + ((and (symbol=? (library-ref-name r1) (library-ref-name r2)) + (equal? (library-ref-library r1) (library-ref-library r2))) + 0) + ((string<? (library-ref->string r1) (library-ref->string r2)) + -1) + (else 1))))) + + + (define (fix-names name-map expr) + (let fix ((expr expr)) + (match expr + ((% %library-ref . _) + (lookup name-map expr expr)) + ((% %constant . _) expr) + ((% %lexical-ref . _) expr) + ((% %lexical-set ref expr) + (make-lexical-set ref (fix expr))) + ((% %library-define ref expr) + (make-library-define ref (fix expr))) + ((% %define-syntax . _) expr) + ((% %if test a b) + (make-if (fix test) (fix a) (fix b))) + ((% %call proc args) + (make-call (fix proc) (fix args))) + ((% %call-builtin op args) + (make-call-builtin op (map fix args))) + ((% %sequence a b) + (make-sequence (fix a) (fix b))) + ((% %lambda args body) + (make-lambda args (fix body))) + ((% %letrec in-order? names gensyms exprs body) + (make-letrec in-order? names gensyms (map fix exprs) (fix body))) + (_ (error "unexpected form in fix-names" expr))))) (define (expand-lambda-body body env) - (let loop ((body body) - (env env) - (names '()) - (gensyms '()) - (expressions '())) + (let continue ((body body) + (env env) + (names '()) + (gensyms '()) + (expressions '())) (syntax-case body ('() (if (null? names) @@ -694,25 +778,39 @@ (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f)))) ((expr . expr*) (define expanded-expr (expand expr env)) + (define continue? + (let add-bindings ((expanded-expr expanded-expr)) + (match expanded-expr + ((% %library-define (% %library-ref name _) expr) + (define g (gensym)) + (set! env (add-binding name (make-lexical-ref name g) env)) + (set! names (cons name names)) + (set! gensyms (cons g gensyms)) + (set! expressions (cons expr expressions)) + #t) + ((% %define-syntax name transformer) + (set! env (add-binding name transformer env)) + #t) + ((% %sequence head tail) + (and (add-bindings head) + (add-bindings tail))) + (_ #f)))) (cond - ((library-define? expanded-expr) - (let ((name (library-ref-name (library-define-ref expanded-expr))) - (g (gensym))) - (loop (syntax-map cdr body) - (add-binding name (make-lexical-ref name g) env) - (cons name names) - (cons g gensyms) - (cons (library-define-expression expanded-expr) expressions)))) - ((define-syntax? expanded-expr) - (loop (syntax-map cdr body) - (add-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) env) - names - gensyms - expressions)) + (continue? + (continue (syntax-map cdr body) env names gensyms expressions)) + ((null? names) + (expand-lambda-body-rest body env)) (else - (if (null? names) - (expand-lambda-body-rest body env) - (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body env))))))))) + (let* ((name-map (loop for name in names + for g in gensyms + with m = (make-map compare-library-refs) + do (set! m (insert m (make-library-ref name (environment-library env)) + (make-lexical-ref name g))) + finally (return m))) + (fixed-exprs (loop for expr in expressions + collect (fix-names name-map expr)))) + (make-letrec #t (reverse names) (reverse gensyms) (reverse fixed-exprs) + (expand-lambda-body-rest body env))))))))) (define builtin-lambda @@ -801,8 +899,11 @@ (lambda (x env) (syntax-case x ((_ head tail) - (make-sequence (expand head env) - (expand tail env))) + (define head* (expand head env)) + (match head* + ((% %define-syntax name transformer) + (set! env (add-binding name transformer env)))) + (make-sequence head* (expand tail env))) (_ (raise-syntax-error "unexpected form in builtin-sequence")))))) |