diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/csc/macros-test.csc | 115 | ||||
| -rw-r--r-- | lib/csc/macros.csc | 215 |
2 files changed, 236 insertions, 94 deletions
diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc index def474f..2af86b7 100644 --- a/lib/csc/macros-test.csc +++ b/lib/csc/macros-test.csc @@ -68,7 +68,19 @@ (test builtin-quote (assert-equal - (make-constant '(test 1 2 3)) + (make-call-builtin 'cons + (list + (make-constant 'test) + (make-call-builtin 'cons + (list + (make-constant 1) + (make-call-builtin 'cons + (list + (make-constant 2) + (make-call-builtin 'cons + (list + (make-constant 3) + (make-constant '()))))))))) (expand-body 'main '((quote (test 1 2 3))) builtins-environment) @@ -80,12 +92,12 @@ (make-constant 1) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules (a b) ((foo a) 0) ((foo b) - 1))) + 1)))) (foo b))) builtins-environment) transform-ir1)) @@ -96,9 +108,9 @@ (make-constant 0) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules () - ((foo _) 0))) + ((foo _) 0)))) (foo ignored))) builtins-environment) transform-ir1)) @@ -109,9 +121,9 @@ (make-constant 5) (expand-body 'main '((let-syntax - (foo - (syntax-rules () - ((foo x) x))) + ((foo + (syntax-rules () + ((foo x) x)))) (foo 5))) builtins-environment) transform-ir1)) @@ -122,10 +134,10 @@ (make-constant 1) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules () ((foo x) 0) - ((foo) 1))) + ((foo) 1)))) (foo))) builtins-environment) transform-ir1)) @@ -136,9 +148,9 @@ (make-constant 1) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules () - ((foo a . b) a))) + ((foo a . b) a)))) (foo 1 2 3))) builtins-environment) transform-ir1)) @@ -149,9 +161,9 @@ (make-constant 'a) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules () - ((foo x) (quote x)))) + ((foo x) (quote x))))) (foo a))) builtins-environment) transform-ir1)) @@ -162,11 +174,11 @@ (make-constant 2) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules () ((foo "abc") 0) ((foo "def") 1) - ((foo "ghi") 2))) + ((foo "ghi") 2)))) (foo "ghi"))) builtins-environment) transform-ir1)) @@ -177,9 +189,9 @@ (make-constant 5) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules () - ((foo x ...) (x ...)))) + ((foo x ...) (x ...))))) (foo quote 5))) builtins-environment) transform-ir1)) @@ -190,9 +202,9 @@ (make-constant 5) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules () - ((foo x ... . y) (x ... y)))) + ((foo x ... . y) (x ... y))))) (foo quote . 5))) builtins-environment) transform-ir1)) @@ -200,13 +212,19 @@ (test builtin-syntax-rules-ellipsis-zip (assert-equal - (make-constant '((1 . 3) (2 . 4))) + (make-call-builtin 'cons + (list + (make-call-builtin 'cons (list (make-constant 1) (make-constant 3))) + (make-call-builtin 'cons + (list + (make-call-builtin 'cons (list (make-constant 2) (make-constant 4))) + (make-constant '()))))) (expand-body 'main '((let-syntax - (zip + ((zip (syntax-rules () ((zip (x ...) (y ...)) - (quote ((x . y) ...))))) + (quote ((x . y) ...)))))) (zip (1 2) (3 4)))) builtins-environment) transform-ir1)) @@ -214,13 +232,28 @@ (test builtin-syntax-rules-ellipsis-nested (assert-equal - (make-constant '(1 2 3 4 5)) + (make-call-builtin 'cons + (list + (make-constant 1) + (make-call-builtin 'cons + (list + (make-constant 2) + (make-call-builtin 'cons + (list + (make-constant 3) + (make-call-builtin 'cons + (list + (make-constant 4) + (make-call-builtin 'cons + (list + (make-constant 5) + (make-constant '()))))))))))) (expand-body 'main '((let-syntax - (append + ((append (syntax-rules () ((append (x ...) ...) - (quote (x ... ...))))) + (quote (x ... ...)))))) (append (1 2) (3 4) () (5)))) builtins-environment) transform-ir1)) @@ -231,9 +264,9 @@ (make-constant 5) (expand-body 'main '((let-syntax - (foo + ((foo (syntax-rules ::: () - ((foo x :::) (x :::)))) + ((foo x :::) (x :::))))) (foo quote 5))) builtins-environment) transform-ir1)) @@ -242,13 +275,13 @@ (test builtin-syntax-rules-define (assert-equal (make-library-define (make-library-ref 'exit 'main) - (make-lambda (test-ref 'args) (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main)))))) + (make-lambda (test-ref 'args) (make-call-builtin 'exit (list (make-library-ref 'code 'main))))) (expand-body 'main '((let-syntax - (define + ((define (syntax-rules () ((define (f) body ...) - (builtin-define f (builtin-lambda args body ...))))) + (builtin-define f (builtin-lambda args body ...)))))) (define (exit) (call-builtin exit code)))) builtins-environment) @@ -262,20 +295,20 @@ (test builtin-lambda-ref (assert-equal (make-lambda (test-ref 'args) - (make-sequence (make-constant #f) (test-ref 'args))) + (test-ref 'args)) (expand-body 'main '((builtin-lambda args args)) builtins-environment) transform-ir1)) - (test builtin-case-lambda-defines + (test builtin-lambda-defines (assert-equal (make-lambda (test-ref 'args) (make-letrec #t '(a b) (list (gensym) (gensym)) (list (make-constant 6) (test-ref 'a)) - (make-sequence (make-constant #f) (make-constant 7)))) + (make-constant 7))) (expand-body 'main '((builtin-lambda args (builtin-define a (quote 6)) @@ -285,6 +318,16 @@ transform-ir1)) + (test builtin-lambda-empty + (assert-equal + (make-lambda (test-ref 'args) + (make-constant #f)) + (expand-body 'main + '((builtin-lambda args)) + builtins-environment) + transform-ir1)) + + (test builtin-define-syntax (assert-equal (make-sequence @@ -311,9 +354,7 @@ (test builtin-lexical-set (assert-equal (make-lambda (test-ref 'args) - (make-sequence - (make-constant #f) - (make-lexical-set (test-ref 'args) (make-constant 5)))) + (make-lexical-set (test-ref 'args) (make-constant 5))) (expand-body 'main '((builtin-lambda args (set! args 5))) 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")))))) |