diff options
| -rw-r--r-- | csc/ir1.csc | 69 | ||||
| -rw-r--r-- | csc/macros-test.csc | 25 | ||||
| -rw-r--r-- | csc/macros.csc | 221 |
3 files changed, 189 insertions, 126 deletions
diff --git a/csc/ir1.csc b/csc/ir1.csc index 59911ab..e5fc2dd 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -5,6 +5,9 @@ call? constant-expression constant? + define-syntax-name + define-syntax-transformer + define-syntax? if-alternate if-consequent if-test @@ -32,26 +35,29 @@ lexical-set-gensym lexical-set-name lexical-set? + library-define-expression + library-define-library + library-define-name + library-define? + library-ref-library + library-ref-name + library-ref? make-call make-constant + make-define-syntax make-if make-lambda make-lambda-case make-letrec make-lexical-ref make-lexical-set + make-library-define + make-library-ref make-sequence - make-toplevel-define - make-toplevel-ref make-void sequence-head sequence-tail sequence? - toplevel-define-expression - toplevel-define-name - toplevel-define? - toplevel-ref-name - toplevel-ref? void?) (import (scheme base) (only (csc loop) loop return)) @@ -87,12 +93,14 @@ (gensym lexical-ref-gensym)) - ; <toplevel-ref> name - ; A free reference to a top level variable. - (define-record-type <toplevel-ref> - (make-toplevel-ref name) - toplevel-ref? - (name toplevel-ref-name)) + ; <library-ref> name + ; A free reference to a variable in a library. If the library is 'main, + ; then it is a top-level global variable. + (define-record-type <library-ref> + (make-library-ref name library) + library-ref? + (name library-ref-name) + (library library-ref-library)) ; <lexical-set> name gensym expression @@ -105,13 +113,24 @@ (expression lexical-set-expression)) - ; <toplevel-define> name expression + ; <library-define> name expression ; Defines a new variable in the current library. - (define-record-type <toplevel-define> - (make-toplevel-define name expression) - toplevel-define? - (name toplevel-define-name) - (expression toplevel-define-expression)) + (define-record-type <library-define> + (make-library-define name expression library) + library-define? + (name library-define-name) + (expression library-define-expression) + (library library-define-library)) + + + ; <define-syntax> name transformer + ; Defines a new macro in the current environment. name is the name of the + ; macro. transformer is a macro transformer. + (define-record-type <define-syntax> + (make-define-syntax name transformer) + define-syntax? + (name define-syntax-name) + (transformer define-syntax-transformer)) ; <if> test consequent alternate @@ -198,16 +217,18 @@ (equal? (constant-expression x) (constant-expression y))) ((and (lexical-ref? x) (lexical-ref? y)) (symbol=? (lexical-ref-name x) (lexical-ref-name y))) - ((and (toplevel-ref? x) (toplevel-ref? y)) - (symbol=? (toplevel-ref-name x) (toplevel-ref-name y))) + ((and (library-ref? x) (library-ref? y)) + (symbol=? (library-ref-name x) (library-ref-name y)) + (equal? (library-ref-library x) (library-ref-library y))) ((and (lexical-set? x) (lexical-set? y)) (and (symbol=? (lexical-set-name x) (lexical-set-name y)) (ir1=? (lexical-set-expression x) (lexical-set-expression y)))) - ((and (toplevel-define? x) (toplevel-define? y)) + ((and (library-define? x) (library-define? y)) (and - (symbol=? (toplevel-define-name x) (toplevel-define-name y)) - (ir1=? (toplevel-define-expression x) (toplevel-define-expression y)))) + (symbol=? (library-define-name x) (library-define-name y)) + (ir1=? (library-define-expression x) (library-define-expression y)) + (equal? (library-define-library x) (library-define-library y)))) ((and (if? x) (if? y)) (and (ir1=? (if-test x) (if-test y)) diff --git a/csc/macros-test.csc b/csc/macros-test.csc index 23a9cfc..6211131 100644 --- a/csc/macros-test.csc +++ b/csc/macros-test.csc @@ -9,7 +9,10 @@ lexical-set-name lexical-set? make-constant + make-lexical-ref make-lambda-case + make-letrec + make-library-ref void?) (only (csc testing) assert-equal @@ -175,12 +178,28 @@ builtins-environment))) -(test builtin-case-lambda +(test builtin-case-lambda-cases (assert-equal ir1=? - (make-lambda-case '(x y z) #f #f (make-constant 5) - (make-lambda-case '(a b c) 'd #f (make-constant 6) '())) + (make-lambda-case '(x y z) #f #f (make-sequence (make-void) (make-constant 5)) + (make-lambda-case '(a b c) 'd #f (make-sequence (make-void) (make-constant 6)) '())) (expand '(case-lambda ((x y z) (quote 5)) ((a b c . d) (quote 6))) builtins-environment))) + + +(test builtin-case-lambda-defines + (assert-equal ir1=? + (make-lambda-case '(x) #f #f + (make-letrec #t '(a b) #f + (list (make-constant 6) + (make-lexical-ref 'a #f)) + (make-sequence (make-void) (make-constant 7)))) + (expand + '(case-lambda + ((x) + (builtin-define a (quote 6)) + (builtin-define b a) + (quote 7))) + builtins-environment))) diff --git a/csc/macros.csc b/csc/macros.csc index da2e7b7..0b59b84 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -1,9 +1,10 @@ (define-library (csc macros) (export + builtins-environment expand - program->ir1 + expand-body macro-syntax-error? - builtins-environment) + make-environment) (import (scheme base) (only (csc assert) assert) (only (csc format) sprintf) @@ -12,32 +13,37 @@ gensym=?) (only (csc hash-map) alist->map - map-for-each hash-bytevector insert key-not-found-error? lookup + make-map + map-for-each merge) (only (csc ir1) + define-syntax-name + define-syntax-transformer + define-syntax? lexical-ref-gensym lexical-ref? + library-define-expression + library-define-name + library-define? + library-ref-name + library-ref? make-call make-constant make-lambda make-lambda-case make-letrec + make-lexical-ref + make-library-define + make-library-ref make-sequence - make-toplevel-define - make-toplevel-ref make-void sequence-head sequence-tail sequence? - toplevel-define-expression - toplevel-define-name - toplevel-define? - toplevel-ref-name - toplevel-ref? void?) (only (csc list) revappend @@ -74,15 +80,16 @@ ; symbols is a map with identifiers as keys, and the values can be one of: ; - <lexical-ref>, - ; - <toplevel-ref>, + ; - <library-ref>, ; - or <macro-transformer>. - ; The first two correspond to variables bound lexically or from a module, + ; The first two correspond to variables bound lexically or from a library, ; and the third represents a macro transformer bound in the ; current context. (define-record-type <environment> - (make-environment symbols) + (make-environment symbols library) environment? - (symbols environment-substitutions)) + (symbols environment-substitutions) + (library environment-library)) (define-record-type <syntax-object> @@ -111,12 +118,17 @@ '())) + (define (add-binding identifier binding environment) + (make-environment + (insert (environment-substitutions environment) identifier binding) + (environment-library environment))) + + (define (with-binding identifier binding syntax) - (let ((environment (syntax-object-environment syntax))) - (make-syntax-object - (syntax->expression syntax) - (make-environment (insert (environment-substitutions environment) identifier binding)) - (marks syntax)))) + (make-syntax-object + (syntax->expression syntax) + (add-binding identifier binding (syntax-object-environment syntax)) + (marks syntax))) (define (identifier? s) @@ -150,9 +162,9 @@ (or (and (lexical-ref? b1) (lexical-ref? b2) (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2))) - (and (toplevel-ref? b1) - (toplevel-ref? b2) - (symbol=? (toplevel-ref-name b1) (toplevel-ref-name b2))) + (and (library-ref? b1) + (library-ref? b2) + (symbol=? (library-ref-name b1) (library-ref-name b2))) (and (macro-transformer? b1) (macro-transformer? b2) (eq? (transformer-function b1) (transformer-function b2))))) @@ -279,14 +291,17 @@ (define (resolve-identifier ident) - (let ((substitutions (environment-substitutions (syntax-object-environment 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) (raise-syntax-error "undefined symbol" ident))) - (lookup substitutions (identifier-name ident)))))) + (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 (expand-syntax-object syntax) @@ -300,9 +315,7 @@ ((procedure . arguments) (expand-procedure-call procedure arguments)) (_ (when (identifier? syntax)) - (let ((binding - (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" syntax))) - (lookup (environment-substitutions (syntax-object-environment syntax)) syntax)))) + (let ((binding (resolve-identifier syntax))) (if (macro-transformer? binding) (raise-syntax-error "macro is not allowed in this context" syntax) binding))) @@ -384,7 +397,8 @@ '_ (make-environment (alist->substitutions - (list (cons '_ (make-toplevel-ref '_))))))))) + (list (cons '_ (make-library-ref '_ '(scheme base))))) + '(scheme base)))))) (define (syntax-improper-list-length l) @@ -468,9 +482,8 @@ (+ 1 i) (syntax-map cdr object) (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding))))) - (merge - bindings - (pattern-bindings ellipsis literals p* object)))) + (let ((bindings* (pattern-bindings ellipsis literals p* object))) + (and bindings* (merge bindings bindings*))))) #f))) (underscore (when (is-underscore underscore)) (alist->substitutions '())) @@ -488,8 +501,9 @@ ((p . p*) (syntax-case object ((e . e*) - (merge (pattern-bindings ellipsis literals p e) - (pattern-bindings ellipsis literals p* e*))) + (define pbindings (pattern-bindings ellipsis literals p e)) + (define p*bindings (pattern-bindings ellipsis literals p* e*)) + (and pbindings p*bindings (merge pbindings p*bindings))) (_ #f))) (constant (if (equal? (syntax->expression constant) (syntax->expression object)) @@ -581,16 +595,16 @@ (syntax-case rules ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object all-rules)) ((((_ . pattern) template) . tail) - (let ((bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object)))) - (if bindings - ; We call expand-syntax-object immediately, since macros are - ; allowed to be recursive. - (expand-syntax-object - ; 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))) - (loop tail)))) + (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object))) + (if bindings + ; We call expand-syntax-object immediately, since macros are + ; allowed to be recursive. + (expand-syntax-object + ; 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))) + (loop tail))) (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules))))) @@ -599,8 +613,9 @@ '... (make-environment (alist->substitutions - (list (cons '_ - (make-toplevel-ref '_))))))) + (list (cons '... + (make-library-ref '... '(scheme base))))) + '(scheme base)))) (define builtin-syntax-rules @@ -639,46 +654,56 @@ (_ (raise-syntax-error "unexpected form in split-args-rest" formals)))) - (define (collect-defines acc body) - (cond - ((toplevel-define? body) - (values - (cons body acc) - (make-void))) - ((sequence? body) - (let-values (((acc rest) (collect-defines acc (sequence-head body)))) - (if (void? rest) - (collect-defines acc (sequence-tail body)) - (values - acc - (make-sequence rest (sequence-tail body)))))) - ((void? body) - (values acc body)) - (else - (values (reverse acc) body)))) + (define (expand-lambda-body-rest body) + (let loop ((body body) + (expanded-body (make-void))) + (syntax-case body + ('() + expanded-body) + ((expr . expr*) + (define expanded-expr (expand-syntax-object expr)) + (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)))))) - (define (fix-lambda-body body) - (define-values (defines rest) (collect-defines '() body)) - (define-values (names gensyms vals) (loop for def in defines - collect (toplevel-define-name def) into names - collect (gensym) into gensyms - collect (toplevel-define-expression def) into vals - finally (return (values names gensyms vals)))) - (if (null? names) - rest - (make-letrec - #t - names - gensyms - vals - rest))) + (define (expand-lambda-body body) + (let loop ((body body) + (names '()) + (gensyms '()) + (expressions '())) + (syntax-case body + ('() + (if (null? names) + (make-void) + (make-letrec #t names gensyms expressions (make-void)))) + ((expr . expr*) + (define expanded-expr (expand-syntax-object expr)) + (cond + ((library-define? expanded-expr) + (let ((name (library-define-name expanded-expr)) + (g (gensym))) + (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body)) + (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)) + names + gensyms + expressions)) + (else + (if (null? names) + (expand-lambda-body-rest body) + (make-letrec #t names gensyms expressions (expand-lambda-body-rest body))))))))) (define (case-lambda-helper form) (syntax-case form ('() '()) - (((formals body) . clauses) + (((formals . body) . clauses) (let-values (((args rest) (split-args-rest formals))) (make-lambda-case args @@ -688,7 +713,7 @@ (if rest (cons rest args) args)) - (fix-lambda-body (expand-syntax-object body)) + (expand-lambda-body body) (case-lambda-helper clauses)))) (_ (raise-syntax-error "unexpected form in case-lambda-helper" form)))) @@ -707,7 +732,10 @@ (lambda (x) (syntax-case x ((_ symbol expression) - (make-toplevel-define (identifier-name symbol) (expand-syntax-object expression))) + (make-library-define + (identifier-name symbol) + (expand-syntax-object expression) + (environment-library (syntax-object-environment x)))) (_ (raise-syntax-error "unexpected form in builtin-define" x)))))) @@ -715,29 +743,24 @@ (make-environment (alist->substitutions (list (cons 'syntax-rules builtin-syntax-rules) - (cons '_ (make-toplevel-ref '_)) + (cons '_ (make-library-ref '_ '(scheme base))) + (cons '... (make-library-ref '... '(scheme base))) (cons 'builtin-let-syntax builtin-let-syntax) (cons 'quote builtin-quote) (cons 'case-lambda builtin-case-lambda) - (cons 'builtin-define builtin-define))))) + (cons 'builtin-define builtin-define))) + 'main)) - (define (expand-body environment body) - (loop for expr in body + (define (expand-body body) + (loop with environment = (syntax-object-environment body) + for expr in (syntax->expression body) for expanded-expr = (expand expr environment) for res = expanded-expr then (make-sequence res expanded-expr) finally (return res) - if (toplevel-define? expanded-expr) - do (set! environment (insert environment (toplevel-define-name expanded-expr) (toplevel-define-expression expanded-expr))))) - - - ; A Scheme program consists of one or more import declarations - ; followed by a sequence of expressions and definitions. - ; -- R7RS - (define (program->ir1 program) - (loop for expr in program - for body on program - do (match expr - ; Add this line to make yourself feel better. - ((! ('import ('csc 'builtins))) '()) - (_ (return (expand-body builtins-environment body)))))))) + if (define-syntax? expanded-expr) + do (set! environment + (add-binding + (define-syntax-name expanded-expr) + (define-syntax-transformer expanded-expr) + environment)))))) |