From d4bd262329827738d08a431f9556fbe6fa8d5a80 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Fri, 12 Aug 2022 16:59:42 -0700 Subject: Fix bugs in the macro expander. Now I'm following the rule that you should ignore marks that were added after the binding was defined. I also introduced a lexical environment to handle lambdas. --- lib/csc/macros-test.csc | 27 +++++++ lib/csc/macros.csc | 182 ++++++++++++++++++++++++++---------------------- 2 files changed, 125 insertions(+), 84 deletions(-) (limited to 'lib') diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc index 9b4c128..be573cb 100644 --- a/lib/csc/macros-test.csc +++ b/lib/csc/macros-test.csc @@ -37,6 +37,7 @@ make-letrec make-lexical-ref make-lexical-set + make-library-define make-library-ref make-sequence sequence?) @@ -238,6 +239,22 @@ transform-ir1)) + (test builtin-syntax-rules-define + (assert-equal + (make-library-define (make-library-ref 'exit 'main) + (make-lambda '() #f (make-sequence (make-constant #f) (make-call-builtin 'exit (list (make-library-ref 'code 'main)))))) + (expand-body 'main + '((let-syntax + (define + (syntax-rules () + ((define (f . args) body ...) + (builtin-define f (lambda args body ...))))) + (define (exit) + (call-builtin exit code)))) + builtins-environment) + transform-ir1)) + + (define (test-ref sym) (make-lexical-ref sym (gensym))) @@ -257,6 +274,16 @@ transform-ir1)) + (test builtin-lambda-ref + (assert-equal + (make-lambda (list (test-ref 'x)) #f + (make-sequence (make-constant #f) (test-ref 'x))) + (expand-body 'main + '((lambda (x) x)) + builtins-environment) + transform-ir1)) + + (test builtin-case-lambda-defines (assert-equal (make-lambda (list (test-ref 'x)) #f diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc index fc8aa79..6278142 100644 --- a/lib/csc/macros.csc +++ b/lib/csc/macros.csc @@ -125,13 +125,6 @@ (environment-library environment))) - (define (with-binding identifier binding syntax) - (make-syntax-object - (syntax->expression syntax) - (add-binding identifier binding (syntax-object-environment syntax)) - (marks syntax))) - - (define (identifier? s) (or (symbol? s) (and (syntax-object? s) @@ -177,10 +170,12 @@ (lookup (environment-substitutions (syntax-object-environment s1)) s1))) (s2-binding (guard (e ((key-not-found-error? e) #f)) (lookup (environment-substitutions (syntax-object-environment s2)) s2)))) - (or (and (not s1-binding) + (or (and s1-binding + s2-binding + (binding=? s1-binding s2-binding)) + (and (not s1-binding) (not s2-binding) - (symbol=? (identifier-name s1) (identifier-name s2))) - (binding=? s1-binding s2-binding)))) + (symbol=? (identifier-name s1) (identifier-name s2)))))) (define *next-mark* 0) @@ -220,7 +215,9 @@ (define (with-wrap expression parent) - (decorate (marks parent) expression (syntax-object-environment parent))) + (if (syntax-object? parent) + (decorate (marks parent) expression (syntax-object-environment parent)) + expression)) (define (syntax-map f expr) @@ -275,15 +272,15 @@ (syntax-case-match-pattern y arm ...)))))) - (define (expand-procedure-call procedure arguments) - (let ((expanded-procedure (expand-syntax-object procedure)) + (define (expand-procedure-call procedure arguments env) + (let ((expanded-procedure (expand procedure env)) (expanded-arguments (let loop ((arguments arguments) (expanded-arguments '())) (syntax-case arguments ('() (reverse expanded-arguments)) ((argument . rest) - (let ((expanded-argument (expand-syntax-object argument))) + (let ((expanded-argument (expand argument env))) (loop rest (cons expanded-argument expanded-arguments)))) @@ -291,32 +288,40 @@ (make-call expanded-procedure expanded-arguments))) - (define (resolve-identifier ident) - (let* ((environment (syntax-object-environment ident)) - (substitutions (environment-substitutions environment))) - (or - ; Check whether the variable is lexically bound to a marked identifier. - (guard (e ((key-not-found-error? e) #f)) - (lookup substitutions ident)) - ; Check whether the variable is bound to an unmarked identifier. - (guard (e ((key-not-found-error? e) #f)) - (lookup substitutions (identifier-name ident))) - ; Otherwise insert a library-ref - (make-library-ref (identifier-name ident) (environment-library environment))))) + (define (strip-mark ident) + (make-syntax-object + (identifier-name ident) + (syntax-object-environment ident) + (cdr (marks ident)))) + + + (define (lookup-complicated ident env) + (define e (environment-substitutions env)) + (or (lookup e ident #f) + (and (pair? (marks ident)) + (lookup-complicated (strip-mark ident) env)))) + + + (define (resolve-identifier ident lexical-env) + (or + (lookup-complicated ident lexical-env) + (and (syntax-object? ident) + (lookup-complicated ident (syntax-object-environment ident))) + (make-library-ref (identifier-name ident) (environment-library lexical-env)))) - (define (expand-syntax-object syntax) + (define (expand syntax env) (syntax-case syntax ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax)) ((macro-name . tail) when (identifier? macro-name) - (let ((macro-body (resolve-identifier macro-name))) + (let ((macro-body (resolve-identifier macro-name env))) (if (macro-transformer? macro-body) - ((transformer-function macro-body) syntax) - (expand-procedure-call macro-name tail)))) + ((transformer-function macro-body) syntax env) + (expand-procedure-call macro-name tail env)))) ((procedure . arguments) - (expand-procedure-call procedure arguments)) + (expand-procedure-call procedure arguments env)) (_ when (identifier? syntax) - (let ((binding (resolve-identifier syntax))) + (let ((binding (resolve-identifier syntax env))) (if (macro-transformer? binding) (raise-syntax-error "macro is not allowed in this context" syntax) binding))) @@ -330,10 +335,6 @@ (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax))))) - (define (expand expression environment) - (expand-syntax-object (wrap-syntax expression environment))) - - (define (clean-syntax s) (cond ((pair? s) (cons (clean-syntax (car s)) (clean-syntax (cdr s)))) @@ -343,7 +344,7 @@ (define builtin-quote (make-macro-transformer - (lambda (syntax) + (lambda (syntax env) (syntax-case syntax ((_ datum) (make-constant (clean-syntax datum))) (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax))))))) @@ -602,20 +603,21 @@ (_ template))) - (define (syntax-match ellipsis literals all-rules object) + (define (syntax-match ellipsis literals all-rules env object) (let loop ((rules all-rules)) (syntax-case rules - ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object all-rules)) + ('() (raise-syntax-error "form did not match any patterns in syntax-rules" (clean-syntax object) (clean-syntax all-rules))) ((((_ . pattern) template) . tail) - (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object))) + (define bindings (pattern-bindings ellipsis literals pattern (wrap-syntax (syntax-map cdr object) env))) (if bindings - ; We call expand-syntax-object immediately, since macros are + ; We call expand immediately, since macros are ; allowed to be recursive. - (expand-syntax-object + (expand ; Each time the expander encounters a macro use, it applies an ; antimark to the input form, invokes the associated ; transformer, then applies a fresh mark to the output. - (add-mark (new-mark) (expand-template ellipsis (vec) bindings template))) + (add-mark (new-mark) (expand-template ellipsis (vec) bindings template)) + env) (loop tail))) (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules))))) @@ -632,26 +634,36 @@ (define builtin-syntax-rules (make-macro-transformer - (lambda (syntax-rules-form) + (lambda (syntax-rules-form env1) + ; Merge the lexical and toplevel environments. + (define toplevel-env (if (syntax-object? syntax-rules-form) + (environment-substitutions (syntax-object-environment syntax-rules-form)) + (make-map compare-identifiers))) + (set! syntax-rules-form + (make-syntax-object (syntax->expression syntax-rules-form) + (make-environment + (merge toplevel-env (environment-substitutions env1)) + (environment-library env1)) + (marks syntax-rules-form))) (make-macro-transformer - (lambda (input-form) + (lambda (input-form env) (syntax-case syntax-rules-form ((_ ellipsis literals . rules) when (identifier? ellipsis) - (syntax-match ellipsis literals rules input-form)) + (syntax-match ellipsis literals rules env input-form)) ((_ literals . rules) - (syntax-match default-ellipsis literals rules input-form)) - (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))))) + (syntax-match default-ellipsis literals rules env input-form)) + (_ (raise-syntax-error "unexpected form in syntax-rules" (clean-syntax syntax-rules-form))))))))) (define builtin-let-syntax (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x ((_ (ident transformer-form) body-form) when (identifier? ident) - (let* ((transformer (expand-syntax-object transformer-form)) - (body (expand-syntax-object (with-binding ident transformer body-form)))) + (let* ((transformer (expand transformer-form env)) + (body (expand body-form (add-binding ident transformer env)))) body)) - (_ (raise-syntax-error "unexpected form in let-syntax" x)))))) + (_ (raise-syntax-error "unexpected form in let-syntax" (clean-syntax x))))))) (define (split-args-rest formals) @@ -663,17 +675,17 @@ (values (cons (identifier-name var) args) rest))) (var when (identifier? var) (values '() (identifier-name var))) - (_ (raise-syntax-error "unexpected form in split-args-rest" formals)))) + (_ (raise-syntax-error "unexpected form in split-args-rest" (clean-syntax formals))))) - (define (expand-lambda-body-rest body) + (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-syntax-object 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)) @@ -681,8 +693,9 @@ (make-sequence expanded-body expanded-expr)))))) - (define (expand-lambda-body body) + (define (expand-lambda-body body env) (let loop ((body body) + (env env) (names '()) (gensyms '()) (expressions '())) @@ -692,73 +705,74 @@ (make-constant #f) (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f)))) ((expr . expr*) - (define expanded-expr (expand-syntax-object expr)) + (define expanded-expr (expand expr env)) (cond ((library-define? expanded-expr) (let ((name (library-ref-name (library-define-ref expanded-expr))) (g (gensym))) - (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body)) + (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 (with-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) (syntax-map cdr body)) + (loop (syntax-map cdr body) + (add-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) env) names gensyms expressions)) (else (if (null? names) - (expand-lambda-body-rest body) - (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body))))))))) + (expand-lambda-body-rest body env) + (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body env))))))))) (define builtin-lambda (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x ((_ formals . body) (let-values (((args rest) (split-args-rest formals))) (define refs (map (lambda (name) (make-lexical-ref name (gensym))) args)) - (define environment (syntax-object-environment body)) (loop for ref in refs - do (set! environment (add-binding (lexical-ref-name ref) ref environment))) + do (set! env (add-binding (lexical-ref-name ref) ref env))) (make-lambda refs (if rest (make-lexical-ref rest (gensym)) #f) - (expand-lambda-body (make-syntax-object (syntax->expression body) environment (marks body)))))) + (expand-lambda-body body env)))) (_ (raise-syntax-error "unexpected form in lambda" x)))))) (define builtin-define (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x - ((_ symbol expression) + ((_ symbol expression) when (identifier? symbol) (make-library-define (make-library-ref (identifier-name symbol) - (environment-library (syntax-object-environment x))) - (expand-syntax-object expression))) - (_ (raise-syntax-error "unexpected form in builtin-define" x)))))) + (environment-library env)) + (expand expression env))) + (_ (raise-syntax-error "unexpected form in builtin-define" (clean-syntax x))))))) (define builtin-define-syntax (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x ((_ ident transformer-form) when (identifier? ident) (make-define-syntax (identifier-name ident) - (expand-syntax-object transformer-form))) + (expand transformer-form env))) (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x)))))) (define builtin-call-builtin (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x ((_ op . args) when (identifier? op) (make-call-builtin (identifier-name op) @@ -768,7 +782,7 @@ ('() (reverse expanded-args)) ((head . tail) (loop tail - (cons (expand-syntax-object head) + (cons (expand head env) expanded-args))) (_ (raise-syntax-error "unexpected form in call-builtin")))))) (_ (raise-syntax-error "unexpected form in call-builtin" x)))))) @@ -776,11 +790,11 @@ (define builtin-set (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x ((_ var value) when (identifier? var) - (define var* (expand-syntax-object var)) - (define val* (expand-syntax-object value)) + (define var* (expand var env)) + (define val* (expand value env)) (cond ((lexical-ref? var*) (make-lexical-set var* val*)) @@ -793,22 +807,22 @@ (define builtin-if (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x ((_ test true false) - (make-if (expand-syntax-object test) - (expand-syntax-object true) - (expand-syntax-object false))) + (make-if (expand test env) + (expand true env) + (expand false env))) (_ (raise-syntax-error "unexpected form in builtin-if")))))) (define builtin-sequence (make-macro-transformer - (lambda (x) + (lambda (x env) (syntax-case x ((_ head tail) - (make-sequence (expand-syntax-object head) - (expand-syntax-object tail))) + (make-sequence (expand head env) + (expand tail env))) (_ (raise-syntax-error "unexpected form in builtin-sequence")))))) -- cgit v1.3.1