diff options
Diffstat (limited to 'lib/csc')
| -rw-r--r-- | lib/csc/macros-test.csc | 19 | ||||
| -rw-r--r-- | lib/csc/macros.csc | 110 |
2 files changed, 91 insertions, 38 deletions
diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc index cce95ac..9c4aced 100644 --- a/lib/csc/macros-test.csc +++ b/lib/csc/macros-test.csc @@ -255,6 +255,25 @@ transform-ir1)) + (test builtin-syntax-rules-recursive + (assert-equal + (make-call-builtin 'add + (list (make-constant 1) + (make-call-builtin 'add + (list (make-constant 1) + (make-call-builtin 'add (list (make-constant 1) (make-constant 0))))))) + (expand-body 'main + '((let-syntax + ((macro-len + (syntax-rules () + ((macro-len ()) 0) + ((macro-len (_ tail ...)) + (call-builtin add 1 (macro-len (tail ...))))))) + (macro-len (a b c)))) + builtins-environment) + transform-ir1)) + + (define (test-ref sym) (make-lexical-ref sym (gensym))) diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc index 398f07b..91bcef1 100644 --- a/lib/csc/macros.csc +++ b/lib/csc/macros.csc @@ -328,7 +328,7 @@ (define (expand syntax env) (syntax-case syntax - ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax)) + ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)")) ((macro-name . tail) when (identifier? macro-name) (let ((macro-body (resolve-identifier macro-name env))) (if (macro-transformer? macro-body) @@ -490,6 +490,20 @@ res)) + (define (init-template-bindings ellipsis literals pattern) + (guard (e (#t (error "fuck" e))) + (syntax-case pattern + ((p ellip . p*) when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip)) + (merge + (map-ellipsis-binding (init-template-bindings ellipsis literals p)) + (init-template-bindings ellipsis literals p*))) + ((head . tail) (merge (init-template-bindings ellipsis literals head) + (init-template-bindings ellipsis literals tail))) + (ident when (identifier? ident) + (alist->substitutions (list (cons ident (make-ellipsis-binding (vec) 1))))) + (_ (alist->substitutions '()))))) + + (define (pattern-bindings ellipsis literals pattern object) (syntax-case pattern (lit when (matches-literals literals lit) @@ -503,7 +517,7 @@ (if (>= n m) (let loop ((i 0) (object object) - (bindings (alist->substitutions '()))) + (bindings (init-template-bindings ellipsis literals p))) (if (< i n-m) (and (pair? (syntax->expression object)) @@ -555,10 +569,6 @@ ; 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)) @@ -583,41 +593,59 @@ s1)))) + (define (scan-for-ellipsis-args ellipsis-nesting substitutions template) + (syntax-case template + ('() #f) + (ident when (identifier? ident) + (define binding (lookup substitutions ident #f)) + (and binding + (ellipsis-binding? binding) + (loop for i from 0 below (vec-length ellipsis-nesting) + with v = (ellipsis-binding-objects binding) + do (set! v (vec-ref v (vec-ref ellipsis-nesting i))) + finally (return (vec-length v))))) + ((head . tail) + (define n1 (scan-for-ellipsis-args ellipsis-nesting substitutions head)) + (define n2 (scan-for-ellipsis-args ellipsis-nesting substitutions tail)) + (or (and n1 n2 + (min n1 n2)) + n1 + n2)) + (_ #f))) + + (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)) - (let-values (((extra-ellipses tail) - (let loop ((tail tail) - (extra-ellipses '())) - (syntax-case tail - ((ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) - (loop tail (cons ellip extra-ellipses))) - (_ (values extra-ellipses tail)))))) - (let loop ((i 0) - (expansion (with-wrap '() template))) - (guard (e ((ellipsis-out-of-bounds? e) - (if (= 0 i) - ; Failure was at a higher level. - (raise e) - (syntax-append expansion (expand-template ellipsis ellipsis-nesting substitutions tail))))) - (loop - (+ 1 i) - (syntax-append - expansion - (expand-template - ellipsis - (vec-append ellipsis-nesting i) - substitutions - (with-wrap - (cons - head - extra-ellipses) - template)))))))) + (define num-expansions (scan-for-ellipsis-args ellipsis-nesting substitutions head)) + (unless num-expansions + (raise-syntax-error "no ellipsis variables found in ellipsisized expression" (clean-syntax template))) + (define-values (extra-ellipses tail*) + (let loop ((tail tail) + (extra-ellipses '())) + (syntax-case tail + ((ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) + (loop tail (cons ellip extra-ellipses))) + (_ (values extra-ellipses tail))))) + (loop for i from 0 below num-expansions + with expansion = (with-wrap '() template) + do (set! expansion + (syntax-append + expansion + (expand-template + ellipsis + (vec-append ellipsis-nesting i) + substitutions + (with-wrap + (cons + head + extra-ellipses) + template)))) + finally (return + (syntax-append + expansion + (expand-template ellipsis ellipsis-nesting substitutions tail*))))) ((head . tail) (with-wrap (cons (expand-template ellipsis ellipsis-nesting substitutions head) @@ -839,8 +867,14 @@ (lambda (x env) (syntax-case x ((_ ident transformer-form) when (identifier? ident) + (define transformer* + (make-macro-transformer + (lambda (x env) + ((transformer-function transformer) x env)))) + (define transformer + (expand transformer-form (add-binding ident transformer* env))) (make-define-syntax (identifier-name ident) - (expand transformer-form env))) + transformer)) (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x)))))) |