diff options
Diffstat (limited to 'lib/csc/macros.csc')
| -rw-r--r-- | lib/csc/macros.csc | 976 |
1 files changed, 0 insertions, 976 deletions
diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc deleted file mode 100644 index 91bcef1..0000000 --- a/lib/csc/macros.csc +++ /dev/null @@ -1,976 +0,0 @@ -(define-library (csc macros) - (export - builtins-environment - expand-body - macro-syntax-error? - macro-transformer?) - (import (scheme base) - (only (csc assert) assert) - (only (csc format) sprintf) - (only (csc gensym) - gensym - gensym=?) - (only (csc hash-map) - alist->map - hash-bytevector - insert - key-not-found-error? - lookup - make-comparer - make-map - 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? - lexical-ref-gensym - lexical-ref-name - lexical-ref? - library-define-expression - library-define-ref - library-define? - library-ref-library - library-ref-name - library-ref? - make-call - make-call-builtin - make-constant - make-define-syntax - make-if - make-lambda - make-letrec - make-lexical-ref - make-lexical-set - make-library-define - make-library-ref - make-sequence - sequence-head - sequence-tail - sequence?) - (only (csc list) - revappend - unzip) - (only (csc loop) - loop - return) - (only (csc match) match) - (only (csc vec) - vec - vec-append - vec-length - vec-ref)) - (begin - - - (define-record-type <macro-transformer> - (make-macro-transformer transformer) - macro-transformer? - (transformer transformer-function)) - - - (define-record-type <macro-syntax-error> - (make-macro-syntax-error message irritants) - macro-syntax-error? - (message syntax-error-object-message) - (irritants syntax-error-object-irritants)) - - - (define (raise-syntax-error message . irritants) - (raise (make-macro-syntax-error message irritants))) - - - ; symbols is a map with identifiers as keys, and the values can be one of: - ; - <lexical-ref>, - ; - <library-ref>, - ; - or <macro-transformer>. - ; 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 library) - environment? - (symbols environment-substitutions) - (library environment-library)) - - - (define-record-type <syntax-object> - (make-syntax-object expression environment marks) - syntax-object? - (expression syntax-object-expression) - (environment syntax-object-environment) - (marks syntax-object-marks)) - - - (define (wrap-syntax expression environment) - (if (syntax-object? expression) - expression - (make-syntax-object expression environment '()))) - - - (define (syntax->expression s) - (if (syntax-object? s) - (syntax-object-expression s) - s)) - - - (define (marks s) - (if (syntax-object? s) - (syntax-object-marks s) - '())) - - - (define (add-binding identifier binding environment) - (make-environment - (insert (environment-substitutions environment) identifier binding) - (environment-library environment))) - - - (define (identifier? s) - (or (symbol? s) - (and (syntax-object? s) - (symbol? (syntax-object-expression s))))) - - - (define (marks=? m1 m2) - (and - (= (length m1) (length m2)) - (let loop ((m1 m1) - (m2 m2)) - (if (null? m1) - #t - (and (= (car m1) (car m2)) (loop (cdr m1) (cdr m2))))))) - - - (define (identifier-name s) - (if (syntax-object? s) - (syntax-object-expression s) - s)) - - - (define (bound-identifier=? s1 s2) - (and (symbol=? (identifier-name s1) (identifier-name s2)) - (marks=? (marks s1) (marks s2)))) - - - (define (binding=? b1 b2) - (or (and (lexical-ref? b1) - (lexical-ref? b2) - (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym 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))))) - - - ; free-identifier=? only works on wrapped syntax objects. - (define (free-identifier=? s1 s2) - (let ((s1-binding (guard (e ((key-not-found-error? e) #f)) - (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 s1-binding - s2-binding - (binding=? s1-binding s2-binding)) - (and (not s1-binding) - (not s2-binding) - (symbol=? (identifier-name s1) (identifier-name s2)))))) - - - (define *next-mark* 0) - - - (define (new-mark) - (let ((m *next-mark*)) - (set! *next-mark* (+ 1 *next-mark*)) - m)) - - - (define (add-mark mark expression) - (make-syntax-object - (syntax-object-expression expression) - (syntax-object-environment expression) - (if (and (pair? (syntax-object-marks expression)) - (not (car (syntax-object-marks expression)))) ; Anti-mark. - (cdr (syntax-object-marks expression)) - (cons mark (syntax-object-marks 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 ms expression environment) - (add-marks ms (wrap-syntax expression environment))) - - - (define (with-wrap expression parent) - (if (syntax-object? parent) - (decorate (marks parent) expression (syntax-object-environment parent)) - expression)) - - - (define (syntax-map f expr) - (with-wrap (f (syntax->expression expr)) expr)) - - - (define-record-type <syntax-case-no-match> - (make-syntax-case-no-match) - syntax-case-no-match?) - - - (define-syntax syntax-case-match-pattern - (syntax-rules (_ when) - ((syntax-case-match-pattern x pattern when condition result result* ...) - (syntax-case-match-pattern x pattern - (if condition - (let () result result* ...) - (raise (make-syntax-case-no-match))))) - ((syntax-case-match-pattern x _ result result* ...) - (let () result result* ...)) - ((syntax-case-match-pattern x '() result result* ...) - (if (null? (syntax->expression x)) - (let () result result* ...) - (raise (make-syntax-case-no-match)))) - ((syntax-case-match-pattern x (pattern) result result* ...) - (let ((y x)) - (if (pair? (syntax->expression y)) - (syntax-case-match-pattern (syntax-map car y) pattern - (syntax-case-match-pattern (syntax-map cdr y) '() result result* ...)) - (raise (make-syntax-case-no-match))))) - ((syntax-case-match-pattern x (pattern . rest) result result* ...) - (let ((y x)) - (if (pair? (syntax->expression y)) - (syntax-case-match-pattern (syntax-map car y) pattern - (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...)) - (raise (make-syntax-case-no-match))))) - ((syntax-case-match-pattern x ident result result* ...) - (let ((ident x)) result result* ...)))) - - - ; Yes, I just defined syntax-case in terms of syntax-rules. - ; Are we sure this won't create a black hole? - (define-syntax syntax-case - (syntax-rules () - ((syntax-case x (arm ...)) - (guard (e ((syntax-case-no-match? e) (error "no match in syntax case"))) - (syntax-case-match-pattern x arm ...))) - ((syntax-case x (arm ...) clause clause* ...) - (let ((y x)) - (guard (e ((syntax-case-no-match? e) - (syntax-case y clause clause* ...))) - (syntax-case-match-pattern y arm ...)))))) - - - (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 argument env))) - (loop - rest - (cons expanded-argument expanded-arguments)))) - (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) - (make-call expanded-procedure expanded-arguments))) - - - (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 env) - (syntax-case 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) - ((transformer-function macro-body) syntax env) - (expand-procedure-call macro-name tail env)))) - ((procedure . arguments) - (expand-procedure-call procedure arguments env)) - (_ when (identifier? syntax) - (let ((binding (resolve-identifier syntax env))) - (if (macro-transformer? binding) - (raise-syntax-error "macro is not allowed in this context" syntax) - binding))) - (_ when (let ((expr (syntax->expression syntax))) - (or (boolean? expr) - (char? expr) - (number? expr) - (string? expr) - (vector? expr))) - (make-constant (syntax->expression syntax))) - (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax))))) - - - (define (clean-syntax s) - (cond - ((pair? s) (cons (clean-syntax (car s)) (clean-syntax (cdr s)))) - ((syntax-object? s) (clean-syntax (syntax->expression s))) - (else s))) - - - (define builtin-quote - (make-macro-transformer - (lambda (syntax env) - (syntax-case syntax - ((_ datum) (make-constant (clean-syntax datum))) - (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax))))))) - - - (define (matches-literals literals object) - (unless (list? (syntax->expression literals)) - (raise-syntax-error "invalid form in literals, expecting list" literals)) - (if (not (identifier? object)) - #f - (let ((literal-identifiers - (map - (lambda (lit) (with-wrap lit literals)) - (syntax->expression literals)))) - (let loop ((literal-identifiers literal-identifiers)) - (match literal-identifiers - ('() #f) - ((lit . literals) - (or (free-identifier=? lit object) - (loop literals)))))))) - - - (define (identifier-uuid i) - (sprintf "{}" (list (identifier-name i) (marks i)))) - - - (define (hash-identifier i) - (hash-bytevector (string->utf8 (identifier-uuid i)))) - - - (define (marks<? m1 m2) - (loop for m1* in m1 - for m2* in m2 - if (< m1* m2*) - return #t - else if (> m1* m2*) - return #f - finally (return (< (length m1) (length m2))))) - - - (define compare-identifiers - (make-comparer - hash-identifier - (lambda (i1 i2) - (cond - ((bound-identifier=? i1 i2) 0) - ((or (string<? (symbol->string (identifier-name i1)) (symbol->string (identifier-name i2))) - (marks<? (marks i1) (marks i2))) - -1) - (else 1))))) - - - (define (alist->substitutions l) - (alist->map compare-identifiers l)) - - - (define (is-underscore expression) - (and - (identifier? expression) - (free-identifier=? - expression - (wrap-syntax - '_ - (make-environment - (alist->substitutions - (list (cons '_ (make-library-ref '_ '(scheme base))))) - '(scheme base)))))) - - - (define (syntax-improper-list-length l) - (let loop ((l l) - (n 0)) - (syntax-case l - ('() n) - ((_ . rest) (loop rest (+ 1 n))) - (_ (+ 1 n))))) - - - ; objects is an n-dimensional vec, where n is nesting-level. - (define-record-type <ellipsis-binding> - (make-ellipsis-binding objects nesting-level) - ellipsis-binding? - (objects ellipsis-binding-objects) - (nesting-level ellipsis-binding-nesting-level)) - - - (define (merge-bindings x y) - (assert (= (ellipsis-binding-nesting-level x) (ellipsis-binding-nesting-level y))) - (make-ellipsis-binding - (vec-append (ellipsis-binding-objects x) (ellipsis-binding-objects y)) - (ellipsis-binding-nesting-level x))) - - - (define (ellipsis-substitutions-merge s1 s2) - (map-for-each - (lambda (k v) - (let-values (((s1-binding ok) - (guard (e ((key-not-found-error? e) (values #f #f))) - (values (lookup s1 k) #t)))) - (if ok - (set! s1 (insert s1 k (merge-bindings s1-binding v))) - (set! s1 (insert s1 k v))))) - s2) - s1) - - - (define (map-ellipsis-binding substitutions) - (let ((res (alist->substitutions '()))) - (map-for-each - (lambda (k v) - (if (ellipsis-binding? v) - (set! res - (insert - res - k - (make-ellipsis-binding - (vec (ellipsis-binding-objects v)) - (+ 1 (ellipsis-binding-nesting-level v))))) - (set! res - (insert - res - k - (make-ellipsis-binding - (vec v) - 1))))) - substitutions) - 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) - (if (and (identifier? object) (free-identifier=? object lit)) - (alist->substitutions '()) - #f)) - ((p ellip . p*) when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip)) - (let* ((n (syntax-improper-list-length object)) - (m (syntax-improper-list-length p*)) - (n-m (- n m))) - (if (>= n m) - (let loop ((i 0) - (object object) - (bindings (init-template-bindings ellipsis literals p))) - (if (< i n-m) - (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))) - (underscore when (is-underscore underscore) - (alist->substitutions '())) - (ident when (identifier? ident) - ; Each time the expander encounters a macro use, it applies an - ; antimark to the input form. - ; - ; We would apply it earlier, but the antimark breaks - ; free-identifier=? to check for literals. -- rose - (alist->substitutions (list (cons ident (anti-mark object))))) - ('() - (syntax-case object - ('() (alist->substitutions '())) - (_ #f))) - ((p . p*) - (syntax-case object - ((e . 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)) - (alist->substitutions '()) - #f)))) - - - (define-record-type <ellipsis-out-of-bounds> - (make-ellipsis-out-of-bounds) - ellipsis-out-of-bounds?) - - - (define (ellipsis-ref v i) - (if (< i (vec-length v)) - (vec-ref v i) - (raise (make-ellipsis-out-of-bounds)))) - - - ; Can raise key-not-found-error? or ellipsis-out-of-bounds?. - (define (ellipsis-lookup substitutions ellipsis-nesting key) - (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)) - (let loop ((i 0) - (value (ellipsis-binding-objects n-d-vector))) - (if (< i (vec-length ellipsis-nesting)) - (loop - (+ 1 i) - (ellipsis-ref value (vec-ref ellipsis-nesting i))) - value)) - (raise-syntax-error "reference to pattern variable at incorrect ellipsis nesting level" (clean-syntax key) (vec-length ellipsis-nesting))) - n-d-vector))) - - - (define (syntax-append s1 s2) - (syntax-case s1 - ('() (with-wrap s2 s1)) - ((head . tail) - (with-wrap - (cons head - (syntax-append tail s2)) - 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) - (syntax-case template - ('() (with-wrap '() template)) - ((head ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) - (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) - (expand-template ellipsis ellipsis-nesting substitutions tail)) - template)) - (ident when (identifier? ident) - (guard (e ((key-not-found-error? e) - template)) - (ellipsis-lookup substitutions ellipsis-nesting template))) - (_ template))) - - - (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" (clean-syntax object) (clean-syntax all-rules))) - ((((_ . pattern) template) . tail) - (define bindings (pattern-bindings ellipsis literals pattern (wrap-syntax (syntax-map cdr object) env))) - (if bindings - ; We call expand immediately, since macros are - ; allowed to be recursive. - (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)) - env) - (loop tail))) - (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules))))) - - - (define default-ellipsis - (wrap-syntax - '... - (make-environment - (alist->substitutions - (list (cons '... - (make-library-ref '... '(scheme base))))) - '(scheme base)))) - - - (define builtin-syntax-rules - (make-macro-transformer - (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 env) - (syntax-case syntax-rules-form - ((_ ellipsis literals . rules) when (identifier? ellipsis) - (syntax-match ellipsis literals rules env input-form)) - ((_ literals . rules) - (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 env) - (syntax-case x - ((_ 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) - (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 continue ((body body) - (env env) - (names '()) - (gensyms '()) - (expressions '())) - (syntax-case body - ('() - (if (null? names) - (make-constant #f) - (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 - (continue? - (continue (syntax-map cdr body) env names gensyms expressions)) - ((null? names) - (expand-lambda-body-rest body env)) - (else - (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 - (make-macro-transformer - (lambda (x env) - (syntax-case x - ((_ args . body) when (identifier? args) - (define ref (make-lexical-ref (identifier-name args) (gensym))) - (set! env (add-binding args ref env)) - (make-lambda - ref - (expand-lambda-body body env))))))) - - - (define builtin-define - (make-macro-transformer - (lambda (x env) - (syntax-case x - ((_ symbol expression) when (identifier? symbol) - (make-library-define - (make-library-ref - (identifier-name symbol) - (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 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) - transformer)) - (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x)))))) - - - (define builtin-call-builtin - (make-macro-transformer - (lambda (x env) - (syntax-case x - ((_ op . args) when (identifier? op) - (make-call-builtin (identifier-name op) - (let loop ((args args) - (expanded-args '())) - (syntax-case args - ('() (reverse expanded-args)) - ((head . tail) - (loop tail - (cons (expand head env) - expanded-args))) - (_ (raise-syntax-error "unexpected form in call-builtin")))))) - (_ (raise-syntax-error "unexpected form in call-builtin" x)))))) - - - (define builtin-set - (make-macro-transformer - (lambda (x env) - (syntax-case x - ((_ var value) when (identifier? var) - (define var* (expand var env)) - (define val* (expand value env)) - (cond - ((lexical-ref? var*) - (make-lexical-set var* val*)) - ((library-ref? var*) - (make-library-define var* val*)) - (else - (error "unknown variable form in builtin-set" var*)))) - (_ (raise-syntax-error "unexpected form in builtin-set" x)))))) - - - (define builtin-if - (make-macro-transformer - (lambda (x env) - (syntax-case x - ((_ test true 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 env) - (syntax-case x - ((_ head tail) - (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")))))) - - - (define builtins-environment - (alist->substitutions - (list (cons 'syntax-rules builtin-syntax-rules) - (cons '_ (make-library-ref '_ '(scheme base))) - (cons '... (make-library-ref '... '(scheme base))) - (cons 'let-syntax builtin-let-syntax) - (cons 'quote builtin-quote) - (cons 'builtin-lambda builtin-lambda) - (cons 'builtin-define builtin-define) - (cons 'define-syntax builtin-define-syntax) - (cons 'call-builtin builtin-call-builtin) - (cons 'set! builtin-set) - (cons 'builtin-if builtin-if) - (cons 'builtin-sequence builtin-sequence)))) - - - ; Expands the body of a library, or top level. expand-body can be thought - ; of as a compiler from Scheme to IR1. Macros included in the environment - ; can be used to extend the syntax. Returns an IR1 expression. - (define (expand-body name body env) - (define ident-map (make-map compare-identifiers)) - (map-for-each (lambda (k v) - (set! ident-map (insert ident-map k v))) - env) - (define environment (make-environment ident-map name)) - (if (null? body) - (make-constant #f) - (loop for expr in body - for expanded-expr = (expand expr environment) - for res = expanded-expr then (make-sequence res expanded-expr) - finally (return res) - if (define-syntax? expanded-expr) - do (set! environment - (add-binding - (define-syntax-name expanded-expr) - (define-syntax-transformer expanded-expr) - environment))))))) |