diff options
author | Andy Wingo <wingo@pobox.com> | 2024-11-15 13:57:57 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2024-11-15 13:57:57 +0100 |
commit | 4f05d1709b8dbe5f457b220dd2509c5a187f5416 (patch) | |
tree | 48ac76d9145359aada7c9338f90c6c32d4e29000 /module | |
parent | 3b230745fe5d125752b3aa459409a8152c7a525d (diff) | |
download | guile-4f05d1709b8dbe5f457b220dd2509c5a187f5416.tar.gz |
psyntax: Remove a useless level of let
* module/ice-9/psyntax.scm: Remove let around the body.
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/psyntax.scm | 5557 |
1 files changed, 2778 insertions, 2779 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 1b5e3a2a9..97e4d8524 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -123,2839 +123,2838 @@ fields))) (lp (1+ n)))))))))) - (let () - (define-expansion-constructors) - (define-expansion-accessors lambda src meta body) - - (define (top-level-eval x mod) - (primitive-eval x)) - - (define (local-eval x mod) - (primitive-eval x)) - - (define (sourcev-filename s) (vector-ref s 0)) - (define (sourcev-line s) (vector-ref s 1)) - (define (sourcev-column s) (vector-ref s 2)) - (define (sourcev->alist sourcev) - (define (maybe-acons k v tail) (if v (acons k v tail) tail)) - (and sourcev - (maybe-acons 'filename (sourcev-filename sourcev) - `((line . ,(sourcev-line sourcev)) - (column . ,(sourcev-column sourcev)))))) - - (define (maybe-name-value name val) - (if (lambda? val) - (let ((meta (lambda-meta val))) - (if (assq 'name meta) - val - (make-lambda (lambda-src val) - (acons 'name name meta) - (lambda-body val)))) - val)) - - ;; output constructors - (define build-void - (lambda (sourcev) - (make-void sourcev))) - - (define build-call - (lambda (sourcev fun-exp arg-exps) - (make-call sourcev fun-exp arg-exps))) + (define-expansion-constructors) + (define-expansion-accessors lambda src meta body) + + (define (top-level-eval x mod) + (primitive-eval x)) + + (define (local-eval x mod) + (primitive-eval x)) + + (define (sourcev-filename s) (vector-ref s 0)) + (define (sourcev-line s) (vector-ref s 1)) + (define (sourcev-column s) (vector-ref s 2)) + (define (sourcev->alist sourcev) + (define (maybe-acons k v tail) (if v (acons k v tail) tail)) + (and sourcev + (maybe-acons 'filename (sourcev-filename sourcev) + `((line . ,(sourcev-line sourcev)) + (column . ,(sourcev-column sourcev)))))) + + (define (maybe-name-value name val) + (if (lambda? val) + (let ((meta (lambda-meta val))) + (if (assq 'name meta) + val + (make-lambda (lambda-src val) + (acons 'name name meta) + (lambda-body val)))) + val)) + + ;; output constructors + (define build-void + (lambda (sourcev) + (make-void sourcev))) + + (define build-call + (lambda (sourcev fun-exp arg-exps) + (make-call sourcev fun-exp arg-exps))) - (define build-conditional - (lambda (sourcev test-exp then-exp else-exp) - (make-conditional sourcev test-exp then-exp else-exp))) + (define build-conditional + (lambda (sourcev test-exp then-exp else-exp) + (make-conditional sourcev test-exp then-exp else-exp))) - (define build-lexical-reference - (lambda (type sourcev name var) - (make-lexical-ref sourcev name var))) + (define build-lexical-reference + (lambda (type sourcev name var) + (make-lexical-ref sourcev name var))) - (define build-lexical-assignment - (lambda (sourcev name var exp) - (make-lexical-set sourcev name var (maybe-name-value name exp)))) + (define build-lexical-assignment + (lambda (sourcev name var exp) + (make-lexical-set sourcev name var (maybe-name-value name exp)))) - (define (analyze-variable mod var modref-cont bare-cont) - (if (not mod) - (bare-cont #f var) - (let ((kind (car mod)) - (mod (cdr mod))) - (case kind - ((public) (modref-cont mod var #t)) - ((private hygiene) (if (equal? mod (module-name (current-module))) - (bare-cont mod var) - (modref-cont mod var #f))) - ((bare) (bare-cont var)) - ((primitive) - (syntax-violation #f "primitive not in operator position" var)) - (else (syntax-violation #f "bad module kind" var mod)))))) - - (define build-global-reference - (lambda (sourcev var mod) + (define (analyze-variable mod var modref-cont bare-cont) + (if (not mod) + (bare-cont #f var) + (let ((kind (car mod)) + (mod (cdr mod))) + (case kind + ((public) (modref-cont mod var #t)) + ((private hygiene) (if (equal? mod (module-name (current-module))) + (bare-cont mod var) + (modref-cont mod var #f))) + ((bare) (bare-cont var)) + ((primitive) + (syntax-violation #f "primitive not in operator position" var)) + (else (syntax-violation #f "bad module kind" var mod)))))) + + (define build-global-reference + (lambda (sourcev var mod) + (analyze-variable + mod var + (lambda (mod var public?) + (make-module-ref sourcev mod var public?)) + (lambda (mod var) + (make-toplevel-ref sourcev mod var))))) + + (define build-global-assignment + (lambda (sourcev var exp mod) + (let ((exp (maybe-name-value var exp))) (analyze-variable mod var (lambda (mod var public?) - (make-module-ref sourcev mod var public?)) + (make-module-set sourcev mod var public? exp)) (lambda (mod var) - (make-toplevel-ref sourcev mod var))))) - - (define build-global-assignment - (lambda (sourcev var exp mod) - (let ((exp (maybe-name-value var exp))) - (analyze-variable - mod var - (lambda (mod var public?) - (make-module-set sourcev mod var public? exp)) - (lambda (mod var) - (make-toplevel-set sourcev mod var exp)))))) - - (define build-global-definition - (lambda (sourcev mod var exp) - (make-toplevel-define sourcev (and mod (cdr mod)) var - (maybe-name-value var exp)))) - - (define build-simple-lambda - (lambda (src req rest vars meta exp) - (make-lambda src - meta - ;; hah, a case in which kwargs would be nice. - (make-lambda-case - ;; src req opt rest kw inits vars body else - src req #f rest #f '() vars exp #f)))) - - (define build-case-lambda - (lambda (src meta body) - (make-lambda src meta body))) - - (define build-lambda-case - ;; req := (name ...) - ;; opt := (name ...) | #f - ;; rest := name | #f - ;; kw := (allow-other-keys? (keyword name var) ...) | #f - ;; inits: (init ...) - ;; vars: (sym ...) - ;; vars map to named arguments in the following order: - ;; required, optional (positional), rest, keyword. - ;; the body of a lambda: anything, already expanded - ;; else: lambda-case | #f - (lambda (src req opt rest kw inits vars body else-case) - (make-lambda-case src req opt rest kw inits vars body else-case))) - - (define build-primcall - (lambda (src name args) - (make-primcall src name args))) - - (define build-primref - (lambda (src name) - (make-primitive-ref src name))) - - (define (build-data src exp) - (make-const src exp)) - - (define build-sequence - (lambda (src exps) - (if (null? (cdr exps)) - (car exps) - (make-seq src (car exps) (build-sequence #f (cdr exps)))))) - - (define build-let - (lambda (src ids vars val-exps body-exp) - (let ((val-exps (map maybe-name-value ids val-exps))) - (if (null? vars) - body-exp - (make-let src ids vars val-exps body-exp))))) - - (define build-named-let - (lambda (src ids vars val-exps body-exp) - (let ((f (car vars)) - (f-name (car ids)) - (vars (cdr vars)) - (ids (cdr ids))) - (let ((proc (build-simple-lambda src ids #f vars '() body-exp))) - (make-letrec - src #f - (list f-name) (list f) (list (maybe-name-value f-name proc)) - (build-call src (build-lexical-reference 'fun src f-name f) - (map maybe-name-value ids val-exps))))))) - - (define build-letrec - (lambda (src in-order? ids vars val-exps body-exp) + (make-toplevel-set sourcev mod var exp)))))) + + (define build-global-definition + (lambda (sourcev mod var exp) + (make-toplevel-define sourcev (and mod (cdr mod)) var + (maybe-name-value var exp)))) + + (define build-simple-lambda + (lambda (src req rest vars meta exp) + (make-lambda src + meta + ;; hah, a case in which kwargs would be nice. + (make-lambda-case + ;; src req opt rest kw inits vars body else + src req #f rest #f '() vars exp #f)))) + + (define build-case-lambda + (lambda (src meta body) + (make-lambda src meta body))) + + (define build-lambda-case + ;; req := (name ...) + ;; opt := (name ...) | #f + ;; rest := name | #f + ;; kw := (allow-other-keys? (keyword name var) ...) | #f + ;; inits: (init ...) + ;; vars: (sym ...) + ;; vars map to named arguments in the following order: + ;; required, optional (positional), rest, keyword. + ;; the body of a lambda: anything, already expanded + ;; else: lambda-case | #f + (lambda (src req opt rest kw inits vars body else-case) + (make-lambda-case src req opt rest kw inits vars body else-case))) + + (define build-primcall + (lambda (src name args) + (make-primcall src name args))) + + (define build-primref + (lambda (src name) + (make-primitive-ref src name))) + + (define (build-data src exp) + (make-const src exp)) + + (define build-sequence + (lambda (src exps) + (if (null? (cdr exps)) + (car exps) + (make-seq src (car exps) (build-sequence #f (cdr exps)))))) + + (define build-let + (lambda (src ids vars val-exps body-exp) + (let ((val-exps (map maybe-name-value ids val-exps))) (if (null? vars) body-exp - (make-letrec src in-order? ids vars - (map maybe-name-value ids val-exps) - body-exp)))) - - - (define (gen-lexical id) - ;; Generate a unique symbol for a lexical variable. These need to - ;; be symbols as they are embedded in Tree-IL. Lexicals from - ;; different separately compiled modules can coexist, for example - ;; if a macro defined in module A is used in a separately-compiled - ;; module B, so they do need to be unique. However we assume that - ;; generally a module corresponds to a compilation unit, so there - ;; is no need to be unique across separately-compiled instances of - ;; the same module, and that therefore we can use a deterministic - ;; per-module counter instead of the global counter of 'gensym' so - ;; that the generated identifier is reproducible. - (module-gensym (symbol->string id))) - - (define-syntax no-source (identifier-syntax #f)) - - (define (datum-sourcev datum) - (let ((props (source-properties datum))) - (and (pair? props) - (vector (assq-ref props 'filename) - (assq-ref props 'line) - (assq-ref props 'column))))) - - (define source-annotation - (lambda (x) - ;; Normally X is a syntax object. However, if it comes from a - ;; read hash extension, X might be a plain sexp with source - ;; properties. - (if (syntax? x) - (syntax-sourcev x) - (datum-sourcev x)))) - - (define-syntax-rule (arg-check pred? e who) - (let ((x e)) - (if (not (pred? x)) (syntax-violation who "invalid argument" x)))) - - ;; compile-time environments - - ;; wrap and environment comprise two level mapping. - ;; wrap : id --> label - ;; env : label --> <element> - - ;; environments are represented in two parts: a lexical part and a - ;; global part. The lexical part is a simple list of associations - ;; from labels to bindings. The global part is implemented by - ;; Guile's module system and associates symbols with bindings. - - ;; global (assumed global variable) and displaced-lexical (see below) - ;; do not show up in any environment; instead, they are fabricated by - ;; resolve-identifier when it finds no other bindings. - - ;; <environment> ::= ((<label> . <binding>)*) - - ;; identifier bindings include a type and a value - - ;; <binding> ::= (macro . <procedure>) macros - ;; (syntax-parameter . <procedure>) syntax parameters - ;; (core . <procedure>) core forms - ;; (module-ref . <procedure>) @ or @@ - ;; (begin) begin - ;; (define) define - ;; (define-syntax) define-syntax - ;; (define-syntax-parameter) define-syntax-parameter - ;; (local-syntax . rec?) let-syntax/letrec-syntax - ;; (eval-when) eval-when - ;; (syntax . (<var> . <level>)) pattern variables - ;; (global) assumed global variable - ;; (lexical . <var>) lexical variables - ;; (ellipsis . <identifier>) custom ellipsis - ;; (displaced-lexical) displaced lexicals - ;; <level> ::= <non-negative integer> - ;; <var> ::= symbol returned by gen-lexical - - ;; a macro is a user-defined syntactic-form. a core is a - ;; system-defined syntactic form. begin, define, define-syntax, - ;; define-syntax-parameter, and eval-when are treated specially - ;; since they are sensitive to whether the form is at top-level and - ;; (except for eval-when) can denote valid internal definitions. - - ;; a pattern variable is a variable introduced by syntax-case and can - ;; be referenced only within a syntax form. - - ;; any identifier for which no top-level syntax definition or local - ;; binding of any kind has been seen is assumed to be a global - ;; variable. - - ;; a lexical variable is a lambda- or letrec-bound variable. - - ;; an ellipsis binding is introduced by the 'with-ellipsis' special - ;; form. - - ;; a displaced-lexical identifier is a lexical identifier removed from - ;; it's scope by the return of a syntax object containing the identifier. - ;; a displaced lexical can also appear when a letrec-syntax-bound - ;; keyword is referenced on the rhs of one of the letrec-syntax clauses. - ;; a displaced lexical should never occur with properly written macros. - - (define-syntax make-binding - (syntax-rules (quote) - ((_ type value) (cons type value)) - ((_ 'type) '(type)) - ((_ type) (cons type '())))) - (define-syntax-rule (binding-type x) - (car x)) - (define-syntax-rule (binding-value x) - (cdr x)) - - (define-syntax null-env (identifier-syntax '())) - - (define extend-env - (lambda (labels bindings r) - (if (null? labels) - r - (extend-env (cdr labels) (cdr bindings) - (cons (cons (car labels) (car bindings)) r))))) + (make-let src ids vars val-exps body-exp))))) + + (define build-named-let + (lambda (src ids vars val-exps body-exp) + (let ((f (car vars)) + (f-name (car ids)) + (vars (cdr vars)) + (ids (cdr ids))) + (let ((proc (build-simple-lambda src ids #f vars '() body-exp))) + (make-letrec + src #f + (list f-name) (list f) (list (maybe-name-value f-name proc)) + (build-call src (build-lexical-reference 'fun src f-name f) + (map maybe-name-value ids val-exps))))))) + + (define build-letrec + (lambda (src in-order? ids vars val-exps body-exp) + (if (null? vars) + body-exp + (make-letrec src in-order? ids vars + (map maybe-name-value ids val-exps) + body-exp)))) + + + (define (gen-lexical id) + ;; Generate a unique symbol for a lexical variable. These need to + ;; be symbols as they are embedded in Tree-IL. Lexicals from + ;; different separately compiled modules can coexist, for example + ;; if a macro defined in module A is used in a separately-compiled + ;; module B, so they do need to be unique. However we assume that + ;; generally a module corresponds to a compilation unit, so there + ;; is no need to be unique across separately-compiled instances of + ;; the same module, and that therefore we can use a deterministic + ;; per-module counter instead of the global counter of 'gensym' so + ;; that the generated identifier is reproducible. + (module-gensym (symbol->string id))) + + (define-syntax no-source (identifier-syntax #f)) + + (define (datum-sourcev datum) + (let ((props (source-properties datum))) + (and (pair? props) + (vector (assq-ref props 'filename) + (assq-ref props 'line) + (assq-ref props 'column))))) + + (define source-annotation + (lambda (x) + ;; Normally X is a syntax object. However, if it comes from a + ;; read hash extension, X might be a plain sexp with source + ;; properties. + (if (syntax? x) + (syntax-sourcev x) + (datum-sourcev x)))) + + (define-syntax-rule (arg-check pred? e who) + (let ((x e)) + (if (not (pred? x)) (syntax-violation who "invalid argument" x)))) + + ;; compile-time environments + + ;; wrap and environment comprise two level mapping. + ;; wrap : id --> label + ;; env : label --> <element> + + ;; environments are represented in two parts: a lexical part and a + ;; global part. The lexical part is a simple list of associations + ;; from labels to bindings. The global part is implemented by + ;; Guile's module system and associates symbols with bindings. + + ;; global (assumed global variable) and displaced-lexical (see below) + ;; do not show up in any environment; instead, they are fabricated by + ;; resolve-identifier when it finds no other bindings. + + ;; <environment> ::= ((<label> . <binding>)*) + + ;; identifier bindings include a type and a value + + ;; <binding> ::= (macro . <procedure>) macros + ;; (syntax-parameter . <procedure>) syntax parameters + ;; (core . <procedure>) core forms + ;; (module-ref . <procedure>) @ or @@ + ;; (begin) begin + ;; (define) define + ;; (define-syntax) define-syntax + ;; (define-syntax-parameter) define-syntax-parameter + ;; (local-syntax . rec?) let-syntax/letrec-syntax + ;; (eval-when) eval-when + ;; (syntax . (<var> . <level>)) pattern variables + ;; (global) assumed global variable + ;; (lexical . <var>) lexical variables + ;; (ellipsis . <identifier>) custom ellipsis + ;; (displaced-lexical) displaced lexicals + ;; <level> ::= <non-negative integer> + ;; <var> ::= symbol returned by gen-lexical + + ;; a macro is a user-defined syntactic-form. a core is a + ;; system-defined syntactic form. begin, define, define-syntax, + ;; define-syntax-parameter, and eval-when are treated specially + ;; since they are sensitive to whether the form is at top-level and + ;; (except for eval-when) can denote valid internal definitions. + + ;; a pattern variable is a variable introduced by syntax-case and can + ;; be referenced only within a syntax form. + + ;; any identifier for which no top-level syntax definition or local + ;; binding of any kind has been seen is assumed to be a global + ;; variable. + + ;; a lexical variable is a lambda- or letrec-bound variable. + + ;; an ellipsis binding is introduced by the 'with-ellipsis' special + ;; form. + + ;; a displaced-lexical identifier is a lexical identifier removed from + ;; it's scope by the return of a syntax object containing the identifier. + ;; a displaced lexical can also appear when a letrec-syntax-bound + ;; keyword is referenced on the rhs of one of the letrec-syntax clauses. + ;; a displaced lexical should never occur with properly written macros. + + (define-syntax make-binding + (syntax-rules (quote) + ((_ type value) (cons type value)) + ((_ 'type) '(type)) + ((_ type) (cons type '())))) + (define-syntax-rule (binding-type x) + (car x)) + (define-syntax-rule (binding-value x) + (cdr x)) + + (define-syntax null-env (identifier-syntax '())) + + (define extend-env + (lambda (labels bindings r) + (if (null? labels) + r + (extend-env (cdr labels) (cdr bindings) + (cons (cons (car labels) (car bindings)) r))))) + + (define extend-var-env + ;; variant of extend-env that forms "lexical" binding + (lambda (labels vars r) + (if (null? labels) + r + (extend-var-env (cdr labels) (cdr vars) + (cons (cons (car labels) (make-binding 'lexical (car vars))) r))))) + + ;; we use a "macros only" environment in expansion of local macro + ;; definitions so that their definitions can use local macros without + ;; attempting to use other lexical identifiers. + (define macros-only-env + (lambda (r) + (if (null? r) + '() + (let ((a (car r))) + (if (memq (cadr a) '(macro syntax-parameter ellipsis)) + (cons a (macros-only-env (cdr r))) + (macros-only-env (cdr r))))))) - (define extend-var-env - ;; variant of extend-env that forms "lexical" binding - (lambda (labels vars r) - (if (null? labels) - r - (extend-var-env (cdr labels) (cdr vars) - (cons (cons (car labels) (make-binding 'lexical (car vars))) r))))) - - ;; we use a "macros only" environment in expansion of local macro - ;; definitions so that their definitions can use local macros without - ;; attempting to use other lexical identifiers. - (define macros-only-env - (lambda (r) - (if (null? r) - '() - (let ((a (car r))) - (if (memq (cadr a) '(macro syntax-parameter ellipsis)) - (cons a (macros-only-env (cdr r))) - (macros-only-env (cdr r))))))) - - (define global-extend - (lambda (type sym val) - (module-define! (current-module) - sym - (make-syntax-transformer sym type val)))) - - - ;; Conceptually, identifiers are always syntax objects. Internally, - ;; however, the wrap is sometimes maintained separately (a source of - ;; efficiency and confusion), so that symbols are also considered - ;; identifiers by id?. Externally, they are always wrapped. - - (define nonsymbol-id? - (lambda (x) - (and (syntax? x) - (symbol? (syntax-expression x))))) - - (define id? - (lambda (x) - (cond - ((symbol? x) #t) - ((syntax? x) (symbol? (syntax-expression x))) - (else #f)))) + (define global-extend + (lambda (type sym val) + (module-define! (current-module) + sym + (make-syntax-transformer sym type val)))) - (define-syntax-rule (id-sym-name e) - (let ((x e)) - (if (syntax? x) - (syntax-expression x) - x))) - - (define id-sym-name&marks - (lambda (x w) - (if (syntax? x) - (values - (syntax-expression x) - (join-marks (wrap-marks w) (wrap-marks (syntax-wrap x)))) - (values x (wrap-marks w))))) - - ;; syntax object wraps - - ;; <wrap> ::= ((<mark> ...) . (<subst> ...)) - ;; <subst> ::= shift | <subs> - ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...)) - ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...)) - - (define-syntax make-wrap (identifier-syntax cons)) - (define-syntax wrap-marks (identifier-syntax car)) - (define-syntax wrap-subst (identifier-syntax cdr)) - - (define* (gen-unique #:optional (module (current-module))) - ;; Generate a unique value, used as a mark to identify a scope, or - ;; as a label to associate an identifier with a lexical. They - ;; need to be readable and writable, and because of they way they - ;; are used as labels and marks, distinct from pairs, syntax, and - ;; the symbol `top'. Unique values from different separately - ;; compiled modules can coexist, for example if a macro defined in - ;; module A is used in a separately-compiled module B; however we - ;; assume that generally a module corresponds to a compilation - ;; unit, so there is no need to be unique across - ;; separately-compiled instances of the same module, and that - ;; therefore we can use a deterministic per-module counter instead - ;; of, say, a random number of a long enough length. - (if module - (vector (module-name module) (module-generate-unique-id! module)) - (vector '(guile) (gensym "id")))) - - ;; labels must be comparable with "eq?", have read-write invariance, - ;; and distinct from symbols. Pair labels are used for top-level - ;; definition placeholders. These labels are used for proper - ;; lexicals. - (define (gen-label) - (gen-unique)) - - (define (gen-labels ls) - (if (null? ls) - '() - (cons (gen-label) (gen-labels (cdr ls))))) - - (define (make-ribcage symnames marks labels) - (vector 'ribcage symnames marks labels)) - (define (ribcage-symnames ribcage) (vector-ref ribcage 1)) - (define (ribcage-marks ribcage) (vector-ref ribcage 2)) - (define (ribcage-labels ribcage) (vector-ref ribcage 3)) - (define (set-ribcage-symnames! ribcage x) (vector-set! ribcage 1 x)) - (define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x)) - (define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x)) - - (define-syntax empty-wrap (identifier-syntax '(()))) - (define-syntax top-wrap (identifier-syntax '((top)))) - - ;; Marks must be comparable with "eq?" and distinct from pairs and - ;; the symbol top. We do not use integers so that marks will remain - ;; unique even across file compiles. - - (define-syntax the-anti-mark (identifier-syntax #f)) - - (define anti-mark - (lambda (w) - (make-wrap (cons the-anti-mark (wrap-marks w)) - (cons 'shift (wrap-subst w))))) - - (define (new-mark) - (gen-unique)) - - ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for - ;; internal definitions, in which the ribcages are built incrementally - (define-syntax-rule (make-empty-ribcage) - (make-ribcage '() '() '())) - - (define extend-ribcage! - ;; must receive ids with complete wraps - (lambda (ribcage id label) - (set-ribcage-symnames! ribcage - (cons (syntax-expression id) - (ribcage-symnames ribcage))) - (set-ribcage-marks! ribcage - (cons (wrap-marks (syntax-wrap id)) - (ribcage-marks ribcage))) - (set-ribcage-labels! ribcage - (cons label (ribcage-labels ribcage))))) - - ;; make-binding-wrap creates vector-based ribcages - (define make-binding-wrap - (lambda (ids labels w) - (if (null? ids) - w + + ;; Conceptually, identifiers are always syntax objects. Internally, + ;; however, the wrap is sometimes maintained separately (a source of + ;; efficiency and confusion), so that symbols are also considered + ;; identifiers by id?. Externally, they are always wrapped. + + (define nonsymbol-id? + (lambda (x) + (and (syntax? x) + (symbol? (syntax-expression x))))) + + (define id? + (lambda (x) + (cond + ((symbol? x) #t) + ((syntax? x) (symbol? (syntax-expression x))) + (else #f)))) + + (define-syntax-rule (id-sym-name e) + (let ((x e)) + (if (syntax? x) + (syntax-expression x) + x))) + + (define id-sym-name&marks + (lambda (x w) + (if (syntax? x) + (values + (syntax-expression x) + (join-marks (wrap-marks w) (wrap-marks (syntax-wrap x)))) + (values x (wrap-marks w))))) + + ;; syntax object wraps + + ;; <wrap> ::= ((<mark> ...) . (<subst> ...)) + ;; <subst> ::= shift | <subs> + ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...)) + ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...)) + + (define-syntax make-wrap (identifier-syntax cons)) + (define-syntax wrap-marks (identifier-syntax car)) + (define-syntax wrap-subst (identifier-syntax cdr)) + + (define* (gen-unique #:optional (module (current-module))) + ;; Generate a unique value, used as a mark to identify a scope, or + ;; as a label to associate an identifier with a lexical. They + ;; need to be readable and writable, and because of they way they + ;; are used as labels and marks, distinct from pairs, syntax, and + ;; the symbol `top'. Unique values from different separately + ;; compiled modules can coexist, for example if a macro defined in + ;; module A is used in a separately-compiled module B; however we + ;; assume that generally a module corresponds to a compilation + ;; unit, so there is no need to be unique across + ;; separately-compiled instances of the same module, and that + ;; therefore we can use a deterministic per-module counter instead + ;; of, say, a random number of a long enough length. + (if module + (vector (module-name module) (module-generate-unique-id! module)) + (vector '(guile) (gensym "id")))) + + ;; labels must be comparable with "eq?", have read-write invariance, + ;; and distinct from symbols. Pair labels are used for top-level + ;; definition placeholders. These labels are used for proper + ;; lexicals. + (define (gen-label) + (gen-unique)) + + (define (gen-labels ls) + (if (null? ls) + '() + (cons (gen-label) (gen-labels (cdr ls))))) + + (define (make-ribcage symnames marks labels) + (vector 'ribcage symnames marks labels)) + (define (ribcage-symnames ribcage) (vector-ref ribcage 1)) + (define (ribcage-marks ribcage) (vector-ref ribcage 2)) + (define (ribcage-labels ribcage) (vector-ref ribcage 3)) + (define (set-ribcage-symnames! ribcage x) (vector-set! ribcage 1 x)) + (define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x)) + (define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x)) + + (define-syntax empty-wrap (identifier-syntax '(()))) + (define-syntax top-wrap (identifier-syntax '((top)))) + + ;; Marks must be comparable with "eq?" and distinct from pairs and + ;; the symbol top. We do not use integers so that marks will remain + ;; unique even across file compiles. + + (define-syntax the-anti-mark (identifier-syntax #f)) + + (define anti-mark + (lambda (w) + (make-wrap (cons the-anti-mark (wrap-marks w)) + (cons 'shift (wrap-subst w))))) + + (define (new-mark) + (gen-unique)) + + ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for + ;; internal definitions, in which the ribcages are built incrementally + (define-syntax-rule (make-empty-ribcage) + (make-ribcage '() '() '())) + + (define extend-ribcage! + ;; must receive ids with complete wraps + (lambda (ribcage id label) + (set-ribcage-symnames! ribcage + (cons (syntax-expression id) + (ribcage-symnames ribcage))) + (set-ribcage-marks! ribcage + (cons (wrap-marks (syntax-wrap id)) + (ribcage-marks ribcage))) + (set-ribcage-labels! ribcage + (cons label (ribcage-labels ribcage))))) + + ;; make-binding-wrap creates vector-based ribcages + (define make-binding-wrap + (lambda (ids labels w) + (if (null? ids) + w + (make-wrap + (wrap-marks w) + (cons + (let ((labelvec (list->vector labels))) + (let ((n (vector-length labelvec))) + (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) + (let f ((ids ids) (i 0)) + (if (not (null? ids)) + (call-with-values + (lambda () (id-sym-name&marks (car ids) w)) + (lambda (symname marks) + (vector-set! symnamevec i symname) + (vector-set! marksvec i marks) + (f (cdr ids) (1+ i)))))) + (make-ribcage symnamevec marksvec labelvec)))) + (wrap-subst w)))))) + + (define smart-append + (lambda (m1 m2) + (if (null? m2) + m1 + (append m1 m2)))) + + (define join-wraps + (lambda (w1 w2) + (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1))) + (if (null? m1) + (if (null? s1) + w2 + (make-wrap + (wrap-marks w2) + (smart-append s1 (wrap-subst w2)))) (make-wrap - (wrap-marks w) - (cons - (let ((labelvec (list->vector labels))) - (let ((n (vector-length labelvec))) - (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) - (let f ((ids ids) (i 0)) - (if (not (null? ids)) - (call-with-values - (lambda () (id-sym-name&marks (car ids) w)) - (lambda (symname marks) - (vector-set! symnamevec i symname) - (vector-set! marksvec i marks) - (f (cdr ids) (1+ i)))))) - (make-ribcage symnamevec marksvec labelvec)))) - (wrap-subst w)))))) - - (define smart-append - (lambda (m1 m2) - (if (null? m2) - m1 - (append m1 m2)))) - - (define join-wraps - (lambda (w1 w2) - (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1))) - (if (null? m1) - (if (null? s1) - w2 - (make-wrap - (wrap-marks w2) - (smart-append s1 (wrap-subst w2)))) - (make-wrap - (smart-append m1 (wrap-marks w2)) - (smart-append s1 (wrap-subst w2))))))) - - (define join-marks - (lambda (m1 m2) - (smart-append m1 m2))) - - (define same-marks? - (lambda (x y) - (or (eq? x y) - (and (not (null? x)) - (not (null? y)) - (eq? (car x) (car y)) - (same-marks? (cdr x) (cdr y)))))) - - (define id-var-name - ;; Syntax objects use wraps to associate names with marked - ;; identifiers. This function returns the name corresponding to - ;; the given identifier and wrap, or the original identifier if no - ;; corresponding name was found. - ;; - ;; The name may be a string created by gen-label, indicating a - ;; lexical binding, or another syntax object, indicating a - ;; reference to a top-level definition created during a previous - ;; macroexpansion. - ;; - ;; For lexical variables, finding a label simply amounts to - ;; looking for an entry with the same symbolic name and the same - ;; marks. Finding a toplevel definition is the same, except we - ;; also have to compare modules, hence the `mod' parameter. - ;; Instead of adding a separate entry in the ribcage for modules, - ;; which wouldn't be used for lexicals, we arrange for the entry - ;; for the name entry to be a pair with the module in its car, and - ;; the name itself in the cdr. So if the name that we find is a - ;; pair, we have to check modules. - ;; - ;; The identifer may be passed in wrapped or unwrapped. In any - ;; case, this routine returns either a symbol, a syntax object, or - ;; a string label. - ;; - (lambda (id w mod) - (define-syntax-rule (first e) - ;; Rely on Guile's multiple-values truncation. - e) - (define search - (lambda (sym subst marks mod) - (if (null? subst) - (values #f marks) - (let ((fst (car subst))) - (if (eq? fst 'shift) - (search sym (cdr subst) (cdr marks) mod) - (let ((symnames (ribcage-symnames fst))) - (if (vector? symnames) - (search-vector-rib sym subst marks symnames fst mod) - (search-list-rib sym subst marks symnames fst mod)))))))) - (define search-list-rib - (lambda (sym subst marks symnames ribcage mod) - (let f ((symnames symnames) - (rlabels (ribcage-labels ribcage)) - (rmarks (ribcage-marks ribcage))) + (smart-append m1 (wrap-marks w2)) + (smart-append s1 (wrap-subst w2))))))) + + (define join-marks + (lambda (m1 m2) + (smart-append m1 m2))) + + (define same-marks? + (lambda (x y) + (or (eq? x y) + (and (not (null? x)) + (not (null? y)) + (eq? (car x) (car y)) + (same-marks? (cdr x) (cdr y)))))) + + (define id-var-name + ;; Syntax objects use wraps to associate names with marked + ;; identifiers. This function returns the name corresponding to + ;; the given identifier and wrap, or the original identifier if no + ;; corresponding name was found. + ;; + ;; The name may be a string created by gen-label, indicating a + ;; lexical binding, or another syntax object, indicating a + ;; reference to a top-level definition created during a previous + ;; macroexpansion. + ;; + ;; For lexical variables, finding a label simply amounts to + ;; looking for an entry with the same symbolic name and the same + ;; marks. Finding a toplevel definition is the same, except we + ;; also have to compare modules, hence the `mod' parameter. + ;; Instead of adding a separate entry in the ribcage for modules, + ;; which wouldn't be used for lexicals, we arrange for the entry + ;; for the name entry to be a pair with the module in its car, and + ;; the name itself in the cdr. So if the name that we find is a + ;; pair, we have to check modules. + ;; + ;; The identifer may be passed in wrapped or unwrapped. In any + ;; case, this routine returns either a symbol, a syntax object, or + ;; a string label. + ;; + (lambda (id w mod) + (define-syntax-rule (first e) + ;; Rely on Guile's multiple-values truncation. + e) + (define search + (lambda (sym subst marks mod) + (if (null? subst) + (values #f marks) + (let ((fst (car subst))) + (if (eq? fst 'shift) + (search sym (cdr subst) (cdr marks) mod) + (let ((symnames (ribcage-symnames fst))) + (if (vector? symnames) + (search-vector-rib sym subst marks symnames fst mod) + (search-list-rib sym subst marks symnames fst mod)))))))) + (define search-list-rib + (lambda (sym subst marks symnames ribcage mod) + (let f ((symnames symnames) + (rlabels (ribcage-labels ribcage)) + (rmarks (ribcage-marks ribcage))) + (cond + ((null? symnames) (search sym (cdr subst) marks mod)) + ((and (eq? (car symnames) sym) (same-marks? marks (car rmarks))) + (let ((n (car rlabels))) + (if (pair? n) + (if (equal? mod (car n)) + (values (cdr n) marks) + (f (cdr symnames) (cdr rlabels) (cdr rmarks))) + (values n marks)))) + (else (f (cdr symnames) (cdr rlabels) (cdr rmarks))))))) + (define search-vector-rib + (lambda (sym subst marks symnames ribcage mod) + (let ((n (vector-length symnames))) + (let f ((i 0)) (cond - ((null? symnames) (search sym (cdr subst) marks mod)) - ((and (eq? (car symnames) sym) (same-marks? marks (car rmarks))) - (let ((n (car rlabels))) + ((= i n) (search sym (cdr subst) marks mod)) + ((and (eq? (vector-ref symnames i) sym) + (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) + (let ((n (vector-ref (ribcage-labels ribcage) i))) (if (pair? n) (if (equal? mod (car n)) (values (cdr n) marks) - (f (cdr symnames) (cdr rlabels) (cdr rmarks))) + (f (1+ i))) (values n marks)))) - (else (f (cdr symnames) (cdr rlabels) (cdr rmarks))))))) - (define search-vector-rib - (lambda (sym subst marks symnames ribcage mod) - (let ((n (vector-length symnames))) - (let f ((i 0)) - (cond - ((= i n) (search sym (cdr subst) marks mod)) - ((and (eq? (vector-ref symnames i) sym) - (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) - (let ((n (vector-ref (ribcage-labels ribcage) i))) - (if (pair? n) - (if (equal? mod (car n)) - (values (cdr n) marks) - (f (1+ i))) - (values n marks)))) - (else (f (1+ i)))))))) - (cond - ((symbol? id) - (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id)) - ((syntax? id) - (let ((id (syntax-expression id)) - (w1 (syntax-wrap id)) - (mod (or (syntax-module id) mod))) - (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) - (call-with-values (lambda () (search id (wrap-subst w) marks mod)) - (lambda (new-id marks) - (or new-id - (first (search id (wrap-subst w1) marks mod)) - id)))))) - (else (syntax-violation 'id-var-name "invalid id" id))))) - - ;; A helper procedure for syntax-locally-bound-identifiers, which - ;; itself is a helper for transformer procedures. - ;; `locally-bound-identifiers' returns a list of all bindings - ;; visible to a syntax object with the given wrap. They are in - ;; order from outer to inner. - ;; - ;; The purpose of this procedure is to give a transformer procedure - ;; references on bound identifiers, that the transformer can then - ;; introduce some of them in its output. As such, the identifiers - ;; are anti-marked, so that rebuild-macro-output doesn't apply new - ;; marks to them. - ;; - (define locally-bound-identifiers - (lambda (w mod) - (define scan - (lambda (subst results) - (if (null? subst) - results - (let ((fst (car subst))) - (if (eq? fst 'shift) - (scan (cdr subst) results) - (let ((symnames (ribcage-symnames fst)) - (marks (ribcage-marks fst))) - (if (vector? symnames) - (scan-vector-rib subst symnames marks results) - (scan-list-rib subst symnames marks results)))))))) - (define scan-list-rib - (lambda (subst symnames marks results) - (let f ((symnames symnames) (marks marks) (results results)) - (if (null? symnames) + (else (f (1+ i)))))))) + (cond + ((symbol? id) + (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id)) + ((syntax? id) + (let ((id (syntax-expression id)) + (w1 (syntax-wrap id)) + (mod (or (syntax-module id) mod))) + (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) + (call-with-values (lambda () (search id (wrap-subst w) marks mod)) + (lambda (new-id marks) + (or new-id + (first (search id (wrap-subst w1) marks mod)) + id)))))) + (else (syntax-violation 'id-var-name "invalid id" id))))) + + ;; A helper procedure for syntax-locally-bound-identifiers, which + ;; itself is a helper for transformer procedures. + ;; `locally-bound-identifiers' returns a list of all bindings + ;; visible to a syntax object with the given wrap. They are in + ;; order from outer to inner. + ;; + ;; The purpose of this procedure is to give a transformer procedure + ;; references on bound identifiers, that the transformer can then + ;; introduce some of them in its output. As such, the identifiers + ;; are anti-marked, so that rebuild-macro-output doesn't apply new + ;; marks to them. + ;; + (define locally-bound-identifiers + (lambda (w mod) + (define scan + (lambda (subst results) + (if (null? subst) + results + (let ((fst (car subst))) + (if (eq? fst 'shift) + (scan (cdr subst) results) + (let ((symnames (ribcage-symnames fst)) + (marks (ribcage-marks fst))) + (if (vector? symnames) + (scan-vector-rib subst symnames marks results) + (scan-list-rib subst symnames marks results)))))))) + (define scan-list-rib + (lambda (subst symnames marks results) + (let f ((symnames symnames) (marks marks) (results results)) + (if (null? symnames) + (scan (cdr subst) results) + (f (cdr symnames) (cdr marks) + (cons (wrap (car symnames) + (anti-mark (make-wrap (car marks) subst)) + mod) + results)))))) + (define scan-vector-rib + (lambda (subst symnames marks results) + (let ((n (vector-length symnames))) + (let f ((i 0) (results results)) + (if (= i n) (scan (cdr subst) results) - (f (cdr symnames) (cdr marks) - (cons (wrap (car symnames) - (anti-mark (make-wrap (car marks) subst)) + (f (1+ i) + (cons (wrap (vector-ref symnames i) + (anti-mark (make-wrap (vector-ref marks i) subst)) mod) - results)))))) - (define scan-vector-rib - (lambda (subst symnames marks results) - (let ((n (vector-length symnames))) - (let f ((i 0) (results results)) - (if (= i n) - (scan (cdr subst) results) - (f (1+ i) - (cons (wrap (vector-ref symnames i) - (anti-mark (make-wrap (vector-ref marks i) subst)) - mod) - results))))))) - (scan (wrap-subst w) '()))) - - ;; Returns three values: binding type, binding value, and the module - ;; (for resolving toplevel vars). - (define (resolve-identifier id w r mod resolve-syntax-parameters?) - (define (resolve-global var mod) - (when (and (not mod) (current-module)) - (warn "module system is booted, we should have a module" var)) - (let ((v (and (not (equal? mod '(primitive))) - (module-variable (if mod - (resolve-module (cdr mod)) - (current-module)) - var)))) - ;; The expander needs to know when a top-level definition from - ;; outside the compilation unit is a macro. - ;; - ;; Additionally if a macro is actually a syntax-parameter, we - ;; might need to resolve its current binding. If the syntax - ;; parameter is locally bound (via syntax-parameterize), then - ;; its variable will be present in `r', the expand-time - ;; environment. It's a kind of double lookup: first we see - ;; that a name is bound to a syntax parameter, then we look - ;; for the current binding of the syntax parameter. - ;; - ;; We use the variable (box) holding the syntax parameter - ;; definition as the key for the second lookup. We use the - ;; variable for two reasons: - ;; - ;; 1. If the syntax parameter is redefined in parallel - ;; (perhaps via a parallel module compilation), the - ;; redefinition keeps the same variable. We don't want to - ;; use a "key" that could change during a redefinition. See - ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27476. - ;; - ;; 2. Using the variable instead of its (symname, modname) - ;; pair allows for syntax parameters to be renamed or - ;; aliased while preserving the syntax parameter's identity. - ;; - (if (and v (variable-bound? v) (macro? (variable-ref v))) - (let* ((m (variable-ref v)) - (type (macro-type m)) - (trans (macro-binding m)) - (trans (if (pair? trans) (car trans) trans))) - (if (eq? type 'syntax-parameter) - (if resolve-syntax-parameters? - (let ((lexical (assq-ref r v))) - ;; A resolved syntax parameter is - ;; indistinguishable from a macro. - (values 'macro - (if lexical - (binding-value lexical) - trans) - mod)) - ;; Return box as value for use in second lookup. - (values type v mod)) - (values type trans mod))) - (values 'global var mod)))) - (define (resolve-lexical label mod) - (let ((b (assq-ref r label))) - (if b - (let ((type (binding-type b)) - (value (binding-value b))) - (if (eq? type 'syntax-parameter) - (if resolve-syntax-parameters? - (values 'macro value mod) - ;; If the syntax parameter was defined within - ;; this compilation unit, use its label as its - ;; lookup key. - (values type label mod)) - (values type value mod))) - (values 'displaced-lexical #f #f)))) - (let ((n (id-var-name id w mod))) + results))))))) + (scan (wrap-subst w) '()))) + + ;; Returns three values: binding type, binding value, and the module + ;; (for resolving toplevel vars). + (define (resolve-identifier id w r mod resolve-syntax-parameters?) + (define (resolve-global var mod) + (when (and (not mod) (current-module)) + (warn "module system is booted, we should have a module" var)) + (let ((v (and (not (equal? mod '(primitive))) + (module-variable (if mod + (resolve-module (cdr mod)) + (current-module)) + var)))) + ;; The expander needs to know when a top-level definition from + ;; outside the compilation unit is a macro. + ;; + ;; Additionally if a macro is actually a syntax-parameter, we + ;; might need to resolve its current binding. If the syntax + ;; parameter is locally bound (via syntax-parameterize), then + ;; its variable will be present in `r', the expand-time + ;; environment. It's a kind of double lookup: first we see + ;; that a name is bound to a syntax parameter, then we look + ;; for the current binding of the syntax parameter. + ;; + ;; We use the variable (box) holding the syntax parameter + ;; definition as the key for the second lookup. We use the + ;; variable for two reasons: + ;; + ;; 1. If the syntax parameter is redefined in parallel + ;; (perhaps via a parallel module compilation), the + ;; redefinition keeps the same variable. We don't want to + ;; use a "key" that could change during a redefinition. See + ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27476. + ;; + ;; 2. Using the variable instead of its (symname, modname) + ;; pair allows for syntax parameters to be renamed or + ;; aliased while preserving the syntax parameter's identity. + ;; + (if (and v (variable-bound? v) (macro? (variable-ref v))) + (let* ((m (variable-ref v)) + (type (macro-type m)) + (trans (macro-binding m)) + (trans (if (pair? trans) (car trans) trans))) + (if (eq? type 'syntax-parameter) + (if resolve-syntax-parameters? + (let ((lexical (assq-ref r v))) + ;; A resolved syntax parameter is + ;; indistinguishable from a macro. + (values 'macro + (if lexical + (binding-value lexical) + trans) + mod)) + ;; Return box as value for use in second lookup. + (values type v mod)) + (values type trans mod))) + (values 'global var mod)))) + (define (resolve-lexical label mod) + (let ((b (assq-ref r label))) + (if b + (let ((type (binding-type b)) + (value (binding-value b))) + (if (eq? type 'syntax-parameter) + (if resolve-syntax-parameters? + (values 'macro value mod) + ;; If the syntax parameter was defined within + ;; this compilation unit, use its label as its + ;; lookup key. + (values type label mod)) + (values type value mod))) + (values 'displaced-lexical #f #f)))) + (let ((n (id-var-name id w mod))) + (cond + ((syntax? n) (cond - ((syntax? n) - (cond - ((not (eq? n id)) - ;; This identifier aliased another; recurse to allow - ;; syntax-parameterize to override macro-introduced syntax - ;; parameters. - (resolve-identifier n w r mod resolve-syntax-parameters?)) - (else - ;; Resolved to a free variable that was introduced by this - ;; macro; continue to resolve this global by name. - (resolve-identifier (syntax-expression n) - (syntax-wrap n) - r - (or (syntax-module n) mod) - resolve-syntax-parameters?)))) - ((symbol? n) - (resolve-global n (or (and (syntax? id) - (syntax-module id)) - mod))) + ((not (eq? n id)) + ;; This identifier aliased another; recurse to allow + ;; syntax-parameterize to override macro-introduced syntax + ;; parameters. + (resolve-identifier n w r mod resolve-syntax-parameters?)) (else - (resolve-lexical n (or (and (syntax? id) - (syntax-module id)) - mod)))))) - - (define transformer-environment - (make-fluid - (lambda (k) - (error "called outside the dynamic extent of a syntax transformer")))) - - (define (with-transformer-environment k) - ((fluid-ref transformer-environment) k)) - - ;; free-id=? must be passed fully wrapped ids since (free-id=? x y) - ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. - - (define free-id=? - (lambda (i j) - (let* ((mi (and (syntax? i) (syntax-module i))) - (mj (and (syntax? j) (syntax-module j))) - (ni (id-var-name i empty-wrap mi)) - (nj (id-var-name j empty-wrap mj))) - (define (id-module-binding id mod) - (module-variable - (if mod - ;; The normal case. - (resolve-module (cdr mod)) - ;; Either modules have not been booted, or we have a - ;; raw symbol coming in, which is possible. - (current-module)) - (id-sym-name id))) - (cond - ((syntax? ni) (free-id=? ni j)) - ((syntax? nj) (free-id=? i nj)) - ((symbol? ni) - ;; `i' is not lexically bound. Assert that `j' is free, - ;; and if so, compare their bindings, that they are either - ;; bound to the same variable, or both unbound and have - ;; the same name. - (and (eq? nj (id-sym-name j)) - (let ((bi (id-module-binding i mi))) - (if bi - (eq? bi (id-module-binding j mj)) - (and (not (id-module-binding j mj)) - (eq? ni nj)))) - (eq? (id-module-binding i mi) (id-module-binding j mj)))) - (else - ;; Otherwise `i' is bound, so check that `j' is bound, and - ;; bound to the same thing. - (equal? ni nj)))))) - - ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as - ;; long as the missing portion of the wrap is common to both of the ids - ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w)) - - (define bound-id=? - (lambda (i j) - (if (and (syntax? i) (syntax? j)) - (and (eq? (syntax-expression i) - (syntax-expression j)) - (same-marks? (wrap-marks (syntax-wrap i)) - (wrap-marks (syntax-wrap j)))) - (eq? i j)))) - - ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. - ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids - ;; as long as the missing portion of the wrap is common to all of the - ;; ids. - - (define valid-bound-ids? - (lambda (ids) - (and (let all-ids? ((ids ids)) - (or (null? ids) - (and (id? (car ids)) - (all-ids? (cdr ids))))) - (distinct-bound-ids? ids)))) - - ;; distinct-bound-ids? expects a list of ids and returns #t if there are - ;; no duplicates. It is quadratic on the length of the id list; long - ;; lists could be sorted to make it more efficient. distinct-bound-ids? - ;; may be passed unwrapped (or partially wrapped) ids as long as the - ;; missing portion of the wrap is common to all of the ids. - - (define distinct-bound-ids? - (lambda (ids) - (let distinct? ((ids ids)) - (or (null? ids) - (and (not (bound-id-member? (car ids) (cdr ids))) - (distinct? (cdr ids))))))) - - (define bound-id-member? - (lambda (x list) - (and (not (null? list)) - (or (bound-id=? x (car list)) - (bound-id-member? x (cdr list)))))) - - ;; wrapping expressions and identifiers - - (define wrap - (lambda (x w defmod) - (source-wrap x w #f defmod))) - - (define (wrap-syntax x w defmod) - (make-syntax (syntax-expression x) - w - (or (syntax-module x) defmod) - (syntax-sourcev x))) - (define (source-wrap x w s defmod) - (cond - ((and (null? (wrap-marks w)) - (null? (wrap-subst w)) - (not defmod) - (not s)) - x) - ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod)) - ((null? x) x) - (else (make-syntax x w defmod s)))) - - ;; expanding - - (define expand-sequence - (lambda (body r w s mod) - (build-sequence s - (let dobody ((body body) (r r) (w w) (mod mod)) - (if (null? body) - '() - (let ((first (expand (car body) r w mod))) - (cons first (dobody (cdr body) r w mod)))))))) - - ;; At top-level, we allow mixed definitions and expressions. Like - ;; expand-body we expand in two passes. - ;; - ;; First, from left to right, we expand just enough to know what - ;; expressions are definitions, syntax definitions, and splicing - ;; statements (`begin'). If we anything needs evaluating at - ;; expansion-time, it is expanded directly. - ;; - ;; Otherwise we collect expressions to expand, in thunks, and then - ;; expand them all at the end. This allows all syntax expanders - ;; visible in a toplevel sequence to be visible during the - ;; expansions of all normal definitions and expressions in the - ;; sequence. - ;; - (define expand-top-sequence - (lambda (body r w s m esew mod) - (let* ((r (cons '("placeholder" . (placeholder)) r)) - (ribcage (make-empty-ribcage)) - (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) - (define (record-definition! id var) - (let ((mod (cons 'hygiene (module-name (current-module))))) - ;; Ribcages map symbol+marks to names, mostly for - ;; resolving lexicals. Here to add a mapping for toplevel - ;; definitions we also need to match the module. So, we - ;; put it in the name instead, and make id-var-name handle - ;; the special case of names that are pairs. See the - ;; comments in id-var-name for more. - (extend-ribcage! ribcage id - (cons (or (syntax-module id) mod) - (wrap var top-wrap mod))))) - (define (macro-introduced-identifier? id) - (not (equal? (wrap-marks (syntax-wrap id)) '(top)))) - (define (ensure-fresh-name var) - ;; If a macro introduces a top-level identifier, we attempt - ;; to give it a fresh name by appending the hash of the - ;; expression in which it appears. However, this can fail - ;; for hash collisions, which is more common that one might - ;; think: Guile's hash function stops descending into cdr's - ;; at some point. So, within an expansion unit, fall back - ;; to appending a uniquifying integer. - (define (ribcage-has-var? var) - (let lp ((labels (ribcage-labels ribcage))) - (and (pair? labels) - (let ((wrapped (cdar labels))) - (or (eq? (syntax-expression wrapped) var) - (lp (cdr labels))))))) - (let lp ((unique var) (n 1)) - (if (ribcage-has-var? unique) - (let ((tail (string->symbol (number->string n)))) - (lp (symbol-append var '- tail) (1+ n))) - unique))) - (define (fresh-derived-name id orig-form) - (ensure-fresh-name - (symbol-append - (syntax-expression id) - '- - (string->symbol - ;; FIXME: This encodes hash values into the ABI of - ;; compiled modules; a problem? - (number->string - (hash (syntax->datum orig-form) most-positive-fixnum) - 16))))) - (define (parse body r w s m esew mod) - (let lp ((body body) (exps '())) - (if (null? body) - exps - (lp (cdr body) - (append (parse1 (car body) r w s m esew mod) - exps))))) - (define (parse1 x r w s m esew mod) - (define (current-module-for-expansion mod) - (case (car mod) - ;; If the module was just put in place for hygiene, in a - ;; top-level `begin' always recapture the current - ;; module. If a user wants to override, then we need to - ;; use @@ or similar. - ((hygiene) (cons 'hygiene (module-name (current-module)))) - (else mod))) - (call-with-values - (lambda () - (let ((mod (current-module-for-expansion mod))) - (syntax-type x r w (source-annotation x) ribcage mod #f))) - (lambda (type value form e w s mod) - (case type - ((define-form) - (let* ((id (wrap value w mod)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-expression id)))) - (record-definition! id var) - (list - (if (eq? m 'c&e) - (let ((x (build-global-definition s mod var (expand e r w mod)))) - (top-level-eval x mod) - (lambda () x)) - (call-with-values - (lambda () (resolve-identifier id empty-wrap r mod #t)) - (lambda (type* value* mod*) - ;; If the identifier to be bound is currently bound to a - ;; macro, then immediately discard that binding. - (if (eq? type* 'macro) - (top-level-eval (build-global-definition - s mod var (build-void s)) - mod)) - (lambda () - (build-global-definition s mod var (expand e r w mod))))))))) - ((define-syntax-form define-syntax-parameter-form) - (let* ((id (wrap value w mod)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-expression id)))) - (record-definition! id var) - (case m - ((c) - (cond - ((memq 'compile esew) - (let ((e (expand-install-global mod var type (expand e r w mod)))) - (top-level-eval e mod) - (if (memq 'load esew) - (list (lambda () e)) - '()))) - ((memq 'load esew) - (list (lambda () - (expand-install-global mod var type (expand e r w mod))))) - (else '()))) - ((c&e) - (let ((e (expand-install-global mod var type (expand e r w mod)))) - (top-level-eval e mod) - (list (lambda () e)))) - (else - (if (memq 'eval esew) - (top-level-eval - (expand-install-global mod var type (expand e r w mod)) - mod)) - '())))) - ((begin-form) - (syntax-case e () - ((_ e1 ...) - (parse #'(e1 ...) r w s m esew mod)))) - ((local-syntax-form) - (expand-local-syntax value e r w s mod - (lambda (forms r w s mod) - (parse forms r w s m esew mod)))) - ((eval-when-form) - (syntax-case e () - ((_ (x ...) e1 e2 ...) - (let ((when-list (parse-when-list e #'(x ...))) - (body #'(e1 e2 ...))) - (define (recurse m esew) - (parse body r w s m esew mod)) - (cond - ((eq? m 'e) - (if (memq 'eval when-list) - (recurse (if (memq 'expand when-list) 'c&e 'e) - '(eval)) - (begin - (if (memq 'expand when-list) - (top-level-eval - (expand-top-sequence body r w s 'e '(eval) mod) - mod)) - '()))) - ((memq 'load when-list) - (if (or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (recurse 'c&e '(compile load)) - (if (memq m '(c c&e)) - (recurse 'c '(load)) - '()))) - ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (top-level-eval - (expand-top-sequence body r w s 'e '(eval) mod) - mod) - '()) - (else - '())))))) - (else + ;; Resolved to a free variable that was introduced by this + ;; macro; continue to resolve this global by name. + (resolve-identifier (syntax-expression n) + (syntax-wrap n) + r + (or (syntax-module n) mod) + resolve-syntax-parameters?)))) + ((symbol? n) + (resolve-global n (or (and (syntax? id) + (syntax-module id)) + mod))) + (else + (resolve-lexical n (or (and (syntax? id) + (syntax-module id)) + mod)))))) + + (define transformer-environment + (make-fluid + (lambda (k) + (error "called outside the dynamic extent of a syntax transformer")))) + + (define (with-transformer-environment k) + ((fluid-ref transformer-environment) k)) + + ;; free-id=? must be passed fully wrapped ids since (free-id=? x y) + ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. + + (define free-id=? + (lambda (i j) + (let* ((mi (and (syntax? i) (syntax-module i))) + (mj (and (syntax? j) (syntax-module j))) + (ni (id-var-name i empty-wrap mi)) + (nj (id-var-name j empty-wrap mj))) + (define (id-module-binding id mod) + (module-variable + (if mod + ;; The normal case. + (resolve-module (cdr mod)) + ;; Either modules have not been booted, or we have a + ;; raw symbol coming in, which is possible. + (current-module)) + (id-sym-name id))) + (cond + ((syntax? ni) (free-id=? ni j)) + ((syntax? nj) (free-id=? i nj)) + ((symbol? ni) + ;; `i' is not lexically bound. Assert that `j' is free, + ;; and if so, compare their bindings, that they are either + ;; bound to the same variable, or both unbound and have + ;; the same name. + (and (eq? nj (id-sym-name j)) + (let ((bi (id-module-binding i mi))) + (if bi + (eq? bi (id-module-binding j mj)) + (and (not (id-module-binding j mj)) + (eq? ni nj)))) + (eq? (id-module-binding i mi) (id-module-binding j mj)))) + (else + ;; Otherwise `i' is bound, so check that `j' is bound, and + ;; bound to the same thing. + (equal? ni nj)))))) + + ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as + ;; long as the missing portion of the wrap is common to both of the ids + ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w)) + + (define bound-id=? + (lambda (i j) + (if (and (syntax? i) (syntax? j)) + (and (eq? (syntax-expression i) + (syntax-expression j)) + (same-marks? (wrap-marks (syntax-wrap i)) + (wrap-marks (syntax-wrap j)))) + (eq? i j)))) + + ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. + ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids + ;; as long as the missing portion of the wrap is common to all of the + ;; ids. + + (define valid-bound-ids? + (lambda (ids) + (and (let all-ids? ((ids ids)) + (or (null? ids) + (and (id? (car ids)) + (all-ids? (cdr ids))))) + (distinct-bound-ids? ids)))) + + ;; distinct-bound-ids? expects a list of ids and returns #t if there are + ;; no duplicates. It is quadratic on the length of the id list; long + ;; lists could be sorted to make it more efficient. distinct-bound-ids? + ;; may be passed unwrapped (or partially wrapped) ids as long as the + ;; missing portion of the wrap is common to all of the ids. + + (define distinct-bound-ids? + (lambda (ids) + (let distinct? ((ids ids)) + (or (null? ids) + (and (not (bound-id-member? (car ids) (cdr ids))) + (distinct? (cdr ids))))))) + + (define bound-id-member? + (lambda (x list) + (and (not (null? list)) + (or (bound-id=? x (car list)) + (bound-id-member? x (cdr list)))))) + + ;; wrapping expressions and identifiers + + (define wrap + (lambda (x w defmod) + (source-wrap x w #f defmod))) + + (define (wrap-syntax x w defmod) + (make-syntax (syntax-expression x) + w + (or (syntax-module x) defmod) + (syntax-sourcev x))) + (define (source-wrap x w s defmod) + (cond + ((and (null? (wrap-marks w)) + (null? (wrap-subst w)) + (not defmod) + (not s)) + x) + ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod)) + ((null? x) x) + (else (make-syntax x w defmod s)))) + + ;; expanding + + (define expand-sequence + (lambda (body r w s mod) + (build-sequence s + (let dobody ((body body) (r r) (w w) (mod mod)) + (if (null? body) + '() + (let ((first (expand (car body) r w mod))) + (cons first (dobody (cdr body) r w mod)))))))) + + ;; At top-level, we allow mixed definitions and expressions. Like + ;; expand-body we expand in two passes. + ;; + ;; First, from left to right, we expand just enough to know what + ;; expressions are definitions, syntax definitions, and splicing + ;; statements (`begin'). If we anything needs evaluating at + ;; expansion-time, it is expanded directly. + ;; + ;; Otherwise we collect expressions to expand, in thunks, and then + ;; expand them all at the end. This allows all syntax expanders + ;; visible in a toplevel sequence to be visible during the + ;; expansions of all normal definitions and expressions in the + ;; sequence. + ;; + (define expand-top-sequence + (lambda (body r w s m esew mod) + (let* ((r (cons '("placeholder" . (placeholder)) r)) + (ribcage (make-empty-ribcage)) + (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) + (define (record-definition! id var) + (let ((mod (cons 'hygiene (module-name (current-module))))) + ;; Ribcages map symbol+marks to names, mostly for + ;; resolving lexicals. Here to add a mapping for toplevel + ;; definitions we also need to match the module. So, we + ;; put it in the name instead, and make id-var-name handle + ;; the special case of names that are pairs. See the + ;; comments in id-var-name for more. + (extend-ribcage! ribcage id + (cons (or (syntax-module id) mod) + (wrap var top-wrap mod))))) + (define (macro-introduced-identifier? id) + (not (equal? (wrap-marks (syntax-wrap id)) '(top)))) + (define (ensure-fresh-name var) + ;; If a macro introduces a top-level identifier, we attempt + ;; to give it a fresh name by appending the hash of the + ;; expression in which it appears. However, this can fail + ;; for hash collisions, which is more common that one might + ;; think: Guile's hash function stops descending into cdr's + ;; at some point. So, within an expansion unit, fall back + ;; to appending a uniquifying integer. + (define (ribcage-has-var? var) + (let lp ((labels (ribcage-labels ribcage))) + (and (pair? labels) + (let ((wrapped (cdar labels))) + (or (eq? (syntax-expression wrapped) var) + (lp (cdr labels))))))) + (let lp ((unique var) (n 1)) + (if (ribcage-has-var? unique) + (let ((tail (string->symbol (number->string n)))) + (lp (symbol-append var '- tail) (1+ n))) + unique))) + (define (fresh-derived-name id orig-form) + (ensure-fresh-name + (symbol-append + (syntax-expression id) + '- + (string->symbol + ;; FIXME: This encodes hash values into the ABI of + ;; compiled modules; a problem? + (number->string + (hash (syntax->datum orig-form) most-positive-fixnum) + 16))))) + (define (parse body r w s m esew mod) + (let lp ((body body) (exps '())) + (if (null? body) + exps + (lp (cdr body) + (append (parse1 (car body) r w s m esew mod) + exps))))) + (define (parse1 x r w s m esew mod) + (define (current-module-for-expansion mod) + (case (car mod) + ;; If the module was just put in place for hygiene, in a + ;; top-level `begin' always recapture the current + ;; module. If a user wants to override, then we need to + ;; use @@ or similar. + ((hygiene) (cons 'hygiene (module-name (current-module)))) + (else mod))) + (call-with-values + (lambda () + (let ((mod (current-module-for-expansion mod))) + (syntax-type x r w (source-annotation x) ribcage mod #f))) + (lambda (type value form e w s mod) + (case type + ((define-form) + (let* ((id (wrap value w mod)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-expression id)))) + (record-definition! id var) (list (if (eq? m 'c&e) - (let ((x (expand-expr type value form e r w s mod))) + (let ((x (build-global-definition s mod var (expand e r w mod)))) (top-level-eval x mod) (lambda () x)) - (lambda () - (expand-expr type value form e r w s mod))))))))) - (let ((exps (map (lambda (x) (x)) - (reverse (parse body r w s m esew mod))))) - (if (null? exps) - (build-void s) - (build-sequence s exps)))))) - - (define expand-install-global - (lambda (mod name type e) - (build-global-definition - no-source - mod - name - (build-primcall - no-source - 'make-syntax-transformer - (list (build-data no-source name) - (build-data no-source - (if (eq? type 'define-syntax-parameter-form) - 'syntax-parameter - 'macro)) - e))))) - - (define parse-when-list - (lambda (e when-list) - ;; `when-list' is syntax'd version of list of situations. We - ;; could match these keywords lexically, via free-id=?, but then - ;; we twingle the definition of eval-when to the bindings of - ;; eval, load, expand, and compile, which is totally unintended. - ;; So do a symbolic match instead. - (let ((result (strip when-list))) - (let lp ((l result)) - (if (null? l) - result - (if (memq (car l) '(compile load eval expand)) - (lp (cdr l)) - (syntax-violation 'eval-when "invalid situation" e - (car l)))))))) - - ;; syntax-type returns seven values: type, value, form, e, w, s, and - ;; mod. The first two are described in the table below. - ;; - ;; type value explanation - ;; ------------------------------------------------------------------- - ;; core procedure core singleton - ;; core-form procedure core form - ;; module-ref procedure @ or @@ singleton - ;; lexical name lexical variable reference - ;; global name global variable reference - ;; begin none begin keyword - ;; define none define keyword - ;; define-syntax none define-syntax keyword - ;; define-syntax-parameter none define-syntax-parameter keyword - ;; local-syntax rec? letrec-syntax/let-syntax keyword - ;; eval-when none eval-when keyword - ;; syntax level pattern variable - ;; displaced-lexical none displaced lexical identifier - ;; lexical-call name call to lexical variable - ;; global-call name call to global variable - ;; primitive-call name call to primitive - ;; call none any other call - ;; begin-form none begin expression - ;; define-form id variable definition - ;; define-syntax-form id syntax definition - ;; define-syntax-parameter-form id syntax parameter definition - ;; local-syntax-form rec? syntax definition - ;; eval-when-form none eval-when form - ;; constant none self-evaluating datum - ;; other none anything else - ;; - ;; form is the entire form. For definition forms (define-form, - ;; define-syntax-form, and define-syntax-parameter-form), e is the - ;; rhs expression. For all others, e is the entire form. w is the - ;; wrap for both form and e. s is the source for the entire form. - ;; mod is the module for both form and e. - ;; - ;; syntax-type expands macros and unwraps as necessary to get to one - ;; of the forms above. It also parses definition forms, although - ;; perhaps this should be done by the consumer. - - (define syntax-type - (lambda (e r w s rib mod for-car?) - (cond - ((symbol? e) - (call-with-values (lambda () (resolve-identifier e w r mod #t)) - (lambda (type value mod*) - (case type - ((macro) - (if for-car? - (values type value e e w s mod) - (syntax-type (expand-macro value e r w s rib mod) - r empty-wrap s rib mod #f))) + (call-with-values + (lambda () (resolve-identifier id empty-wrap r mod #t)) + (lambda (type* value* mod*) + ;; If the identifier to be bound is currently bound to a + ;; macro, then immediately discard that binding. + (if (eq? type* 'macro) + (top-level-eval (build-global-definition + s mod var (build-void s)) + mod)) + (lambda () + (build-global-definition s mod var (expand e r w mod))))))))) + ((define-syntax-form define-syntax-parameter-form) + (let* ((id (wrap value w mod)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-expression id)))) + (record-definition! id var) + (case m + ((c) + (cond + ((memq 'compile esew) + (let ((e (expand-install-global mod var type (expand e r w mod)))) + (top-level-eval e mod) + (if (memq 'load esew) + (list (lambda () e)) + '()))) + ((memq 'load esew) + (list (lambda () + (expand-install-global mod var type (expand e r w mod))))) + (else '()))) + ((c&e) + (let ((e (expand-install-global mod var type (expand e r w mod)))) + (top-level-eval e mod) + (list (lambda () e)))) + (else + (if (memq 'eval esew) + (top-level-eval + (expand-install-global mod var type (expand e r w mod)) + mod)) + '())))) + ((begin-form) + (syntax-case e () + ((_ e1 ...) + (parse #'(e1 ...) r w s m esew mod)))) + ((local-syntax-form) + (expand-local-syntax value e r w s mod + (lambda (forms r w s mod) + (parse forms r w s m esew mod)))) + ((eval-when-form) + (syntax-case e () + ((_ (x ...) e1 e2 ...) + (let ((when-list (parse-when-list e #'(x ...))) + (body #'(e1 e2 ...))) + (define (recurse m esew) + (parse body r w s m esew mod)) + (cond + ((eq? m 'e) + (if (memq 'eval when-list) + (recurse (if (memq 'expand when-list) 'c&e 'e) + '(eval)) + (begin + (if (memq 'expand when-list) + (top-level-eval + (expand-top-sequence body r w s 'e '(eval) mod) + mod)) + '()))) + ((memq 'load when-list) + (if (or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (recurse 'c&e '(compile load)) + (if (memq m '(c c&e)) + (recurse 'c '(load)) + '()))) + ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (top-level-eval + (expand-top-sequence body r w s 'e '(eval) mod) + mod) + '()) + (else + '())))))) + (else + (list + (if (eq? m 'c&e) + (let ((x (expand-expr type value form e r w s mod))) + (top-level-eval x mod) + (lambda () x)) + (lambda () + (expand-expr type value form e r w s mod))))))))) + (let ((exps (map (lambda (x) (x)) + (reverse (parse body r w s m esew mod))))) + (if (null? exps) + (build-void s) + (build-sequence s exps)))))) + + (define expand-install-global + (lambda (mod name type e) + (build-global-definition + no-source + mod + name + (build-primcall + no-source + 'make-syntax-transformer + (list (build-data no-source name) + (build-data no-source + (if (eq? type 'define-syntax-parameter-form) + 'syntax-parameter + 'macro)) + e))))) + + (define parse-when-list + (lambda (e when-list) + ;; `when-list' is syntax'd version of list of situations. We + ;; could match these keywords lexically, via free-id=?, but then + ;; we twingle the definition of eval-when to the bindings of + ;; eval, load, expand, and compile, which is totally unintended. + ;; So do a symbolic match instead. + (let ((result (strip when-list))) + (let lp ((l result)) + (if (null? l) + result + (if (memq (car l) '(compile load eval expand)) + (lp (cdr l)) + (syntax-violation 'eval-when "invalid situation" e + (car l)))))))) + + ;; syntax-type returns seven values: type, value, form, e, w, s, and + ;; mod. The first two are described in the table below. + ;; + ;; type value explanation + ;; ------------------------------------------------------------------- + ;; core procedure core singleton + ;; core-form procedure core form + ;; module-ref procedure @ or @@ singleton + ;; lexical name lexical variable reference + ;; global name global variable reference + ;; begin none begin keyword + ;; define none define keyword + ;; define-syntax none define-syntax keyword + ;; define-syntax-parameter none define-syntax-parameter keyword + ;; local-syntax rec? letrec-syntax/let-syntax keyword + ;; eval-when none eval-when keyword + ;; syntax level pattern variable + ;; displaced-lexical none displaced lexical identifier + ;; lexical-call name call to lexical variable + ;; global-call name call to global variable + ;; primitive-call name call to primitive + ;; call none any other call + ;; begin-form none begin expression + ;; define-form id variable definition + ;; define-syntax-form id syntax definition + ;; define-syntax-parameter-form id syntax parameter definition + ;; local-syntax-form rec? syntax definition + ;; eval-when-form none eval-when form + ;; constant none self-evaluating datum + ;; other none anything else + ;; + ;; form is the entire form. For definition forms (define-form, + ;; define-syntax-form, and define-syntax-parameter-form), e is the + ;; rhs expression. For all others, e is the entire form. w is the + ;; wrap for both form and e. s is the source for the entire form. + ;; mod is the module for both form and e. + ;; + ;; syntax-type expands macros and unwraps as necessary to get to one + ;; of the forms above. It also parses definition forms, although + ;; perhaps this should be done by the consumer. + + (define syntax-type + (lambda (e r w s rib mod for-car?) + (cond + ((symbol? e) + (call-with-values (lambda () (resolve-identifier e w r mod #t)) + (lambda (type value mod*) + (case type + ((macro) + (if for-car? + (values type value e e w s mod) + (syntax-type (expand-macro value e r w s rib mod) + r empty-wrap s rib mod #f))) + ((global) + ;; Toplevel definitions may resolve to bindings with + ;; different names or in different modules. + (values type value e value w s mod*)) + (else (values type value e e w s mod)))))) + ((pair? e) + (let ((first (car e))) + (call-with-values + (lambda () (syntax-type first r w s rib mod #t)) + (lambda (ftype fval fform fe fw fs fmod) + (case ftype + ((lexical) + (values 'lexical-call fval e e w s mod)) ((global) - ;; Toplevel definitions may resolve to bindings with - ;; different names or in different modules. - (values type value e value w s mod*)) - (else (values type value e e w s mod)))))) - ((pair? e) - (let ((first (car e))) - (call-with-values - (lambda () (syntax-type first r w s rib mod #t)) - (lambda (ftype fval fform fe fw fs fmod) - (case ftype - ((lexical) - (values 'lexical-call fval e e w s mod)) - ((global) - (if (equal? fmod '(primitive)) - (values 'primitive-call fval e e w s mod) - ;; If we got here via an (@@ ...) expansion, we - ;; need to make sure the fmod information is - ;; propagated back correctly -- hence this - ;; consing. - (values 'global-call (make-syntax fval w fmod fs) - e e w s mod))) - ((macro) - (syntax-type (expand-macro fval e r w s rib mod) - r empty-wrap s rib mod for-car?)) - ((module-ref) - (call-with-values (lambda () (fval e r w mod)) - (lambda (e r w s mod) - (syntax-type e r w s rib mod for-car?)))) - ((core) - (values 'core-form fval e e w s mod)) - ((local-syntax) - (values 'local-syntax-form fval e e w s mod)) - ((begin) - (values 'begin-form #f e e w s mod)) - ((eval-when) - (values 'eval-when-form #f e e w s mod)) - ((define) - (syntax-case e () - ((_ name val) - (id? #'name) - (values 'define-form #'name e #'val w s mod)) - ((_ (name . args) e1 e2 ...) - (and (id? #'name) - (valid-bound-ids? (lambda-var-list #'args))) - ;; need lambda here... - (values 'define-form (wrap #'name w mod) - (wrap e w mod) - (source-wrap - (cons #'lambda (wrap #'(args e1 e2 ...) w mod)) - empty-wrap s #f) - empty-wrap s mod)) - ((_ name) - (id? #'name) - (values 'define-form (wrap #'name w mod) - (wrap e w mod) - #'(if #f #f) - empty-wrap s mod)))) - ((define-syntax) - (syntax-case e () - ((_ name val) - (id? #'name) - (values 'define-syntax-form #'name e #'val w s mod)))) - ((define-syntax-parameter) - (syntax-case e () - ((_ name val) - (id? #'name) - (values 'define-syntax-parameter-form #'name e #'val w s mod)))) - (else - (values 'call #f e e w s mod))))))) - ((syntax? e) - (syntax-type (syntax-expression e) - r - (join-wraps w (syntax-wrap e)) - (or (source-annotation e) s) rib - (or (syntax-module e) mod) for-car?)) - ((self-evaluating? e) (values 'constant #f e e w s mod)) - (else (values 'other #f e e w s mod))))) - - (define expand - (lambda (e r w mod) - (call-with-values - (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) - (lambda (type value form e w s mod) - (expand-expr type value form e r w s mod))))) - - (define expand-expr - (lambda (type value form e r w s mod) - (case type - ((lexical) - (build-lexical-reference 'value s e value)) - ((core core-form) - ;; apply transformer - (value e r w s mod)) - ((module-ref) - (call-with-values (lambda () (value e r w mod)) - (lambda (e r w s mod) - (expand e r w mod)))) - ((lexical-call) - (expand-call - (let ((id (car e))) - (build-lexical-reference 'fun (source-annotation id) - (if (syntax? id) - (syntax->datum id) - id) - value)) - e r w s mod)) - ((global-call) - (expand-call - (build-global-reference (or (source-annotation (car e)) s) - (if (syntax? value) - (syntax-expression value) - value) - (or (and (syntax? value) - (syntax-module value)) - mod)) - e r w s mod)) - ((primitive-call) - (syntax-case e () - ((_ e ...) - (build-primcall s - value - (map (lambda (e) (expand e r w mod)) - #'(e ...)))))) - ((constant) (build-data s (strip e))) - ((global) (build-global-reference s value mod)) - ((call) (expand-call (expand (car e) r w mod) e r w s mod)) - ((begin-form) - (syntax-case e () - ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod)) - ((_) - (syntax-violation #f "sequence of zero expressions" - (source-wrap e w s mod))))) - ((local-syntax-form) - (expand-local-syntax value e r w s mod expand-sequence)) - ((eval-when-form) - (syntax-case e () - ((_ (x ...) e1 e2 ...) - (let ((when-list (parse-when-list e #'(x ...)))) - (if (memq 'eval when-list) - (expand-sequence #'(e1 e2 ...) r w s mod) - (expand-void)))))) - ((define-form define-syntax-form define-syntax-parameter-form) - (syntax-violation #f "definition in expression context, where definitions are not allowed," - (source-wrap form w s mod))) - ((syntax) - (syntax-violation #f "reference to pattern variable outside syntax form" - (source-wrap e w s mod))) - ((displaced-lexical) - (syntax-violation #f "reference to identifier outside its scope" - (source-wrap e w s mod))) - (else (syntax-violation #f "unexpected syntax" - (source-wrap e w s mod)))))) - - (define expand-call - (lambda (x e r w s mod) - (syntax-case e () - ((e0 e1 ...) - (build-call s x - (map (lambda (e) (expand e r w mod)) #'(e1 ...))))))) - - ;; (What follows is my interpretation of what's going on here -- Andy) - ;; - ;; A macro takes an expression, a tree, the leaves of which are identifiers - ;; and datums. Identifiers are symbols along with a wrap and a module. For - ;; efficiency, subtrees that share wraps and modules may be grouped as one - ;; syntax object. + (if (equal? fmod '(primitive)) + (values 'primitive-call fval e e w s mod) + ;; If we got here via an (@@ ...) expansion, we + ;; need to make sure the fmod information is + ;; propagated back correctly -- hence this + ;; consing. + (values 'global-call (make-syntax fval w fmod fs) + e e w s mod))) + ((macro) + (syntax-type (expand-macro fval e r w s rib mod) + r empty-wrap s rib mod for-car?)) + ((module-ref) + (call-with-values (lambda () (fval e r w mod)) + (lambda (e r w s mod) + (syntax-type e r w s rib mod for-car?)))) + ((core) + (values 'core-form fval e e w s mod)) + ((local-syntax) + (values 'local-syntax-form fval e e w s mod)) + ((begin) + (values 'begin-form #f e e w s mod)) + ((eval-when) + (values 'eval-when-form #f e e w s mod)) + ((define) + (syntax-case e () + ((_ name val) + (id? #'name) + (values 'define-form #'name e #'val w s mod)) + ((_ (name . args) e1 e2 ...) + (and (id? #'name) + (valid-bound-ids? (lambda-var-list #'args))) + ;; need lambda here... + (values 'define-form (wrap #'name w mod) + (wrap e w mod) + (source-wrap + (cons #'lambda (wrap #'(args e1 e2 ...) w mod)) + empty-wrap s #f) + empty-wrap s mod)) + ((_ name) + (id? #'name) + (values 'define-form (wrap #'name w mod) + (wrap e w mod) + #'(if #f #f) + empty-wrap s mod)))) + ((define-syntax) + (syntax-case e () + ((_ name val) + (id? #'name) + (values 'define-syntax-form #'name e #'val w s mod)))) + ((define-syntax-parameter) + (syntax-case e () + ((_ name val) + (id? #'name) + (values 'define-syntax-parameter-form #'name e #'val w s mod)))) + (else + (values 'call #f e e w s mod))))))) + ((syntax? e) + (syntax-type (syntax-expression e) + r + (join-wraps w (syntax-wrap e)) + (or (source-annotation e) s) rib + (or (syntax-module e) mod) for-car?)) + ((self-evaluating? e) (values 'constant #f e e w s mod)) + (else (values 'other #f e e w s mod))))) + + (define expand + (lambda (e r w mod) + (call-with-values + (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) + (lambda (type value form e w s mod) + (expand-expr type value form e r w s mod))))) + + (define expand-expr + (lambda (type value form e r w s mod) + (case type + ((lexical) + (build-lexical-reference 'value s e value)) + ((core core-form) + ;; apply transformer + (value e r w s mod)) + ((module-ref) + (call-with-values (lambda () (value e r w mod)) + (lambda (e r w s mod) + (expand e r w mod)))) + ((lexical-call) + (expand-call + (let ((id (car e))) + (build-lexical-reference 'fun (source-annotation id) + (if (syntax? id) + (syntax->datum id) + id) + value)) + e r w s mod)) + ((global-call) + (expand-call + (build-global-reference (or (source-annotation (car e)) s) + (if (syntax? value) + (syntax-expression value) + value) + (or (and (syntax? value) + (syntax-module value)) + mod)) + e r w s mod)) + ((primitive-call) + (syntax-case e () + ((_ e ...) + (build-primcall s + value + (map (lambda (e) (expand e r w mod)) + #'(e ...)))))) + ((constant) (build-data s (strip e))) + ((global) (build-global-reference s value mod)) + ((call) (expand-call (expand (car e) r w mod) e r w s mod)) + ((begin-form) + (syntax-case e () + ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod)) + ((_) + (syntax-violation #f "sequence of zero expressions" + (source-wrap e w s mod))))) + ((local-syntax-form) + (expand-local-syntax value e r w s mod expand-sequence)) + ((eval-when-form) + (syntax-case e () + ((_ (x ...) e1 e2 ...) + (let ((when-list (parse-when-list e #'(x ...)))) + (if (memq 'eval when-list) + (expand-sequence #'(e1 e2 ...) r w s mod) + (expand-void)))))) + ((define-form define-syntax-form define-syntax-parameter-form) + (syntax-violation #f "definition in expression context, where definitions are not allowed," + (source-wrap form w s mod))) + ((syntax) + (syntax-violation #f "reference to pattern variable outside syntax form" + (source-wrap e w s mod))) + ((displaced-lexical) + (syntax-violation #f "reference to identifier outside its scope" + (source-wrap e w s mod))) + (else (syntax-violation #f "unexpected syntax" + (source-wrap e w s mod)))))) + + (define expand-call + (lambda (x e r w s mod) + (syntax-case e () + ((e0 e1 ...) + (build-call s x + (map (lambda (e) (expand e r w mod)) #'(e1 ...))))))) + + ;; (What follows is my interpretation of what's going on here -- Andy) + ;; + ;; A macro takes an expression, a tree, the leaves of which are identifiers + ;; and datums. Identifiers are symbols along with a wrap and a module. For + ;; efficiency, subtrees that share wraps and modules may be grouped as one + ;; syntax object. + ;; + ;; Going into the expansion, the expression is given an anti-mark, which + ;; logically propagates to all leaves. Then, in the new expression returned + ;; from the transfomer, if we see an expression with an anti-mark, we know it + ;; pertains to the original expression; conversely, expressions without the + ;; anti-mark are known to be introduced by the transformer. + ;; + ;; OK, good until now. We know this algorithm does lexical scoping + ;; appropriately because it's widely known in the literature, and psyntax is + ;; widely used. But what about modules? Here we're on our own. What we do is + ;; to mark the module of expressions produced by a macro as pertaining to the + ;; module that was current when the macro was defined -- that is, free + ;; identifiers introduced by a macro are scoped in the macro's module, not in + ;; the expansion's module. Seems to work well. + ;; + ;; The only wrinkle is when we want a macro to expand to code in another + ;; module, as is the case for the r6rs `library' form -- the body expressions + ;; should be scoped relative the the new module, the one defined by the macro. + ;; For that, use `(@@ mod-name body)'. + ;; + ;; Part of the macro output will be from the site of the macro use and part + ;; from the macro definition. We allow source information from the macro use + ;; to pass through, but we annotate the parts coming from the macro with the + ;; source location information corresponding to the macro use. It would be + ;; really nice if we could also annotate introduced expressions with the + ;; locations corresponding to the macro definition, but that is not yet + ;; possible. + (define expand-macro + (lambda (p e r w s rib mod) + (define (decorate-source x) + (source-wrap x empty-wrap s #f)) + (define (map* f x) + (cond + ((null? x) x) + ((pair? x) (cons (f (car x)) (map* f (cdr x)))) + (else (f x)))) + (define rebuild-macro-output + (lambda (x m) + (cond ((pair? x) + (decorate-source + (map* (lambda (x) (rebuild-macro-output x m)) x))) + ((syntax? x) + (let ((w (syntax-wrap x))) + (let ((ms (wrap-marks w)) (ss (wrap-subst w))) + (if (and (pair? ms) (eq? (car ms) the-anti-mark)) + ;; output is from original text + (wrap-syntax + x + (make-wrap (cdr ms) + (if rib + (cons rib (cdr ss)) + (cdr ss))) + mod) + ;; output introduced by macro + (wrap-syntax + x + (make-wrap (cons m ms) + (if rib + (cons rib (cons 'shift ss)) + (cons 'shift ss))) + mod))))) + + ((vector? x) + (let* ((n (vector-length x)) + (v (make-vector n))) + (do ((i 0 (1+ i))) + ((= i n) v) + (vector-set! v i + (rebuild-macro-output (vector-ref x i) m))) + (decorate-source v))) + ((symbol? x) + (syntax-violation #f "encountered raw symbol in macro output" + (source-wrap e w (wrap-subst w) mod) x)) + (else (decorate-source x))))) + (with-fluids ((transformer-environment + (lambda (k) (k e r w s rib mod)))) + (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) + (new-mark))))) + + (define expand-body + ;; In processing the forms of the body, we create a new, empty wrap. + ;; This wrap is augmented (destructively) each time we discover that + ;; the next form is a definition. This is done: ;; - ;; Going into the expansion, the expression is given an anti-mark, which - ;; logically propagates to all leaves. Then, in the new expression returned - ;; from the transfomer, if we see an expression with an anti-mark, we know it - ;; pertains to the original expression; conversely, expressions without the - ;; anti-mark are known to be introduced by the transformer. + ;; (1) to allow the first nondefinition form to be a call to + ;; one of the defined ids even if the id previously denoted a + ;; definition keyword or keyword for a macro expanding into a + ;; definition; + ;; (2) to prevent subsequent definition forms (but unfortunately + ;; not earlier ones) and the first nondefinition form from + ;; confusing one of the bound identifiers for an auxiliary + ;; keyword; and + ;; (3) so that we do not need to restart the expansion of the + ;; first nondefinition form, which is problematic anyway + ;; since it might be the first element of a begin that we + ;; have just spliced into the body (meaning if we restarted, + ;; we'd really need to restart with the begin or the macro + ;; call that expanded into the begin, and we'd have to give + ;; up allowing (begin <defn>+ <expr>+), which is itself + ;; problematic since we don't know if a begin contains only + ;; definitions until we've expanded it). ;; - ;; OK, good until now. We know this algorithm does lexical scoping - ;; appropriately because it's widely known in the literature, and psyntax is - ;; widely used. But what about modules? Here we're on our own. What we do is - ;; to mark the module of expressions produced by a macro as pertaining to the - ;; module that was current when the macro was defined -- that is, free - ;; identifiers introduced by a macro are scoped in the macro's module, not in - ;; the expansion's module. Seems to work well. + ;; Before processing the body, we also create a new environment + ;; containing a placeholder for the bindings we will add later and + ;; associate this environment with each form. In processing a + ;; let-syntax or letrec-syntax, the associated environment may be + ;; augmented with local keyword bindings, so the environment may + ;; be different for different forms in the body. Once we have + ;; gathered up all of the definitions, we evaluate the transformer + ;; expressions and splice into r at the placeholder the new variable + ;; and keyword bindings. This allows let-syntax or letrec-syntax + ;; forms local to a portion or all of the body to shadow the + ;; definition bindings. ;; - ;; The only wrinkle is when we want a macro to expand to code in another - ;; module, as is the case for the r6rs `library' form -- the body expressions - ;; should be scoped relative the the new module, the one defined by the macro. - ;; For that, use `(@@ mod-name body)'. + ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced + ;; into the body. ;; - ;; Part of the macro output will be from the site of the macro use and part - ;; from the macro definition. We allow source information from the macro use - ;; to pass through, but we annotate the parts coming from the macro with the - ;; source location information corresponding to the macro use. It would be - ;; really nice if we could also annotate introduced expressions with the - ;; locations corresponding to the macro definition, but that is not yet - ;; possible. - (define expand-macro - (lambda (p e r w s rib mod) - (define (decorate-source x) - (source-wrap x empty-wrap s #f)) - (define (map* f x) - (cond - ((null? x) x) - ((pair? x) (cons (f (car x)) (map* f (cdr x)))) - (else (f x)))) - (define rebuild-macro-output - (lambda (x m) - (cond ((pair? x) - (decorate-source - (map* (lambda (x) (rebuild-macro-output x m)) x))) - ((syntax? x) - (let ((w (syntax-wrap x))) - (let ((ms (wrap-marks w)) (ss (wrap-subst w))) - (if (and (pair? ms) (eq? (car ms) the-anti-mark)) - ;; output is from original text - (wrap-syntax - x - (make-wrap (cdr ms) - (if rib - (cons rib (cdr ss)) - (cdr ss))) - mod) - ;; output introduced by macro - (wrap-syntax - x - (make-wrap (cons m ms) - (if rib - (cons rib (cons 'shift ss)) - (cons 'shift ss))) - mod))))) - - ((vector? x) - (let* ((n (vector-length x)) - (v (make-vector n))) - (do ((i 0 (1+ i))) - ((= i n) v) - (vector-set! v i - (rebuild-macro-output (vector-ref x i) m))) - (decorate-source v))) - ((symbol? x) - (syntax-violation #f "encountered raw symbol in macro output" - (source-wrap e w (wrap-subst w) mod) x)) - (else (decorate-source x))))) - (with-fluids ((transformer-environment - (lambda (k) (k e r w s rib mod)))) - (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) - (new-mark))))) - - (define expand-body - ;; In processing the forms of the body, we create a new, empty wrap. - ;; This wrap is augmented (destructively) each time we discover that - ;; the next form is a definition. This is done: - ;; - ;; (1) to allow the first nondefinition form to be a call to - ;; one of the defined ids even if the id previously denoted a - ;; definition keyword or keyword for a macro expanding into a - ;; definition; - ;; (2) to prevent subsequent definition forms (but unfortunately - ;; not earlier ones) and the first nondefinition form from - ;; confusing one of the bound identifiers for an auxiliary - ;; keyword; and - ;; (3) so that we do not need to restart the expansion of the - ;; first nondefinition form, which is problematic anyway - ;; since it might be the first element of a begin that we - ;; have just spliced into the body (meaning if we restarted, - ;; we'd really need to restart with the begin or the macro - ;; call that expanded into the begin, and we'd have to give - ;; up allowing (begin <defn>+ <expr>+), which is itself - ;; problematic since we don't know if a begin contains only - ;; definitions until we've expanded it). - ;; - ;; Before processing the body, we also create a new environment - ;; containing a placeholder for the bindings we will add later and - ;; associate this environment with each form. In processing a - ;; let-syntax or letrec-syntax, the associated environment may be - ;; augmented with local keyword bindings, so the environment may - ;; be different for different forms in the body. Once we have - ;; gathered up all of the definitions, we evaluate the transformer - ;; expressions and splice into r at the placeholder the new variable - ;; and keyword bindings. This allows let-syntax or letrec-syntax - ;; forms local to a portion or all of the body to shadow the - ;; definition bindings. - ;; - ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced - ;; into the body. - ;; - ;; outer-form is fully wrapped w/source - (lambda (body outer-form r w mod) - (let* ((r (cons '("placeholder" . (placeholder)) r)) - (ribcage (make-empty-ribcage)) - (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) - (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) - (ids '()) (labels '()) - (var-ids '()) (vars '()) (vals '()) (bindings '()) - (expand-tail-expr #f)) - (cond - ((null? body) - (unless expand-tail-expr - (when (null? ids) - (syntax-violation #f "empty body" outer-form)) - (syntax-violation #f "body should end with an expression" outer-form)) - (unless (valid-bound-ids? ids) - (syntax-violation - #f "invalid or duplicate identifier in definition" - outer-form)) - (set-cdr! r (extend-env labels bindings (cdr r))) - (let ((src (source-annotation outer-form))) - (let lp ((var-ids var-ids) (vars vars) (vals vals) - (tail (expand-tail-expr))) - (cond - ((null? var-ids) tail) - ((not (car var-ids)) - (lp (cdr var-ids) (cdr vars) (cdr vals) - (make-seq src ((car vals)) tail))) - (else - (let ((var-ids (map (lambda (id) - (if id (syntax->datum id) '_)) - (reverse var-ids))) - (vars (map (lambda (var) (or var (gen-lexical '_))) - (reverse vars))) - (vals (map (lambda (expand-expr id) - (if id - (expand-expr) - (make-seq src - (expand-expr) - (build-void src)))) - (reverse vals) (reverse var-ids)))) - (build-letrec src #t var-ids vars vals tail))))))) - (expand-tail-expr - (parse body ids labels - (cons #f var-ids) - (cons #f vars) - (cons expand-tail-expr vals) - bindings #f)) - (else - (let ((e (cdar body)) (er (caar body)) (body (cdr body))) - (call-with-values - (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f)) - (lambda (type value form e w s mod) - (case type - ((define-form) - (let ((id (wrap value w mod)) (label (gen-label))) - (let ((var (gen-var id))) - (extend-ribcage! ribcage id label) - (parse body - (cons id ids) (cons label labels) - (cons id var-ids) - (cons var vars) - (cons (let ((wrapped (source-wrap e w s mod))) - (lambda () - (expand wrapped er empty-wrap mod))) - vals) - (cons (make-binding 'lexical var) bindings) - #f)))) - ((define-syntax-form) - (let ((id (wrap value w mod)) - (label (gen-label)) - (trans-r (macros-only-env er))) - (extend-ribcage! ribcage id label) - ;; As required by R6RS, evaluate the right-hand-sides of internal - ;; syntax definition forms and add their transformers to the - ;; compile-time environment immediately, so that the newly-defined - ;; keywords may be used in definition context within the same - ;; lexical contour. - (set-cdr! r (extend-env - (list label) - (list (make-binding - 'macro - (eval-local-transformer - (expand e trans-r w mod) - mod))) - (cdr r))) - (parse body (cons id ids) - labels var-ids vars vals bindings #f))) - ((define-syntax-parameter-form) - ;; Same as define-syntax-form, different binding type though. - (let ((id (wrap value w mod)) - (label (gen-label)) - (trans-r (macros-only-env er))) - (extend-ribcage! ribcage id label) - (set-cdr! r (extend-env - (list label) - (list (make-binding - 'syntax-parameter - (eval-local-transformer - (expand e trans-r w mod) - mod))) - (cdr r))) - (parse body (cons id ids) - labels var-ids vars vals bindings #f))) - ((begin-form) - (syntax-case e () - ((_ e1 ...) - (parse (let f ((forms #'(e1 ...))) - (if (null? forms) - body - (cons (cons er (wrap (car forms) w mod)) - (f (cdr forms))))) - ids labels var-ids vars vals bindings #f)))) - ((local-syntax-form) - (expand-local-syntax - value e er w s mod - (lambda (forms er w s mod) - (parse (let f ((forms forms)) - (if (null? forms) - body - (cons (cons er (wrap (car forms) w mod)) - (f (cdr forms))))) - ids labels var-ids vars vals bindings #f)))) - (else ; An expression, not a definition. - (let ((wrapped (source-wrap e w s mod))) - (parse body ids labels var-ids vars vals bindings - (lambda () - (expand wrapped er empty-wrap mod))))))))))))))) - - (define expand-local-syntax - (lambda (rec? e r w s mod k) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (let ((ids #'(id ...))) - (if (not (valid-bound-ids? ids)) - (syntax-violation #f "duplicate bound keyword" e) - (let ((labels (gen-labels ids))) - (let ((new-w (make-binding-wrap ids labels w))) - (k #'(e1 e2 ...) - (extend-env - labels - (let ((w (if rec? new-w w)) - (trans-r (macros-only-env r))) - (map (lambda (x) - (make-binding 'macro - (eval-local-transformer - (expand x trans-r w mod) - mod))) - #'(val ...))) - r) - new-w - s - mod)))))) - (_ (syntax-violation #f "bad local syntax definition" - (source-wrap e w s mod)))))) - - (define eval-local-transformer - (lambda (expanded mod) - (let ((p (local-eval expanded mod))) - (if (procedure? p) - p - (syntax-violation #f "nonprocedure transformer" p))))) - - (define expand-void - (lambda () - (build-void no-source))) - - (define ellipsis? - (lambda (e r mod) - (and (nonsymbol-id? e) - ;; If there is a binding for the special identifier - ;; #{ $sc-ellipsis }# in the lexical environment of E, - ;; and if the associated binding type is 'ellipsis', - ;; then the binding's value specifies the custom ellipsis - ;; identifier within that lexical environment, and the - ;; comparison is done using 'bound-id=?'. - (call-with-values - (lambda () (resolve-identifier - (make-syntax '#{ $sc-ellipsis }# - (syntax-wrap e) - (or (syntax-module e) mod) - #f) - empty-wrap r mod #f)) - (lambda (type value mod) - (if (eq? type 'ellipsis) - (bound-id=? e value) - (free-id=? e #'(... ...)))))))) - - (define lambda-formals - (lambda (orig-args) - (define (req args rreq) - (syntax-case args () - (() - (check (reverse rreq) #f)) - ((a . b) (id? #'a) - (req #'b (cons #'a rreq))) - (r (id? #'r) - (check (reverse rreq) #'r)) - (else - (syntax-violation 'lambda "invalid argument list" orig-args args)))) - (define (check req rest) - (cond - ((distinct-bound-ids? (if rest (cons rest req) req)) - (values req #f rest #f)) - (else - (syntax-violation 'lambda "duplicate identifier in argument list" - orig-args)))) - (req orig-args '()))) - - (define expand-simple-lambda - (lambda (e r w s mod req rest meta body) - (let* ((ids (if rest (append req (list rest)) req)) - (vars (map gen-var ids)) - (labels (gen-labels ids))) - (build-simple-lambda - s - (map syntax->datum req) (and rest (syntax->datum rest)) vars - meta - (expand-body body (source-wrap e w s mod) - (extend-var-env labels vars r) - (make-binding-wrap ids labels w) - mod))))) - - (define lambda*-formals - (lambda (orig-args) - (define (req args rreq) - (syntax-case args () - (() - (check (reverse rreq) '() #f '())) - ((a . b) (id? #'a) - (req #'b (cons #'a rreq))) - ((a . b) (eq? (syntax->datum #'a) #:optional) - (opt #'b (reverse rreq) '())) - ((a . b) (eq? (syntax->datum #'a) #:key) - (key #'b (reverse rreq) '() '())) - ((a b) (eq? (syntax->datum #'a) #:rest) - (rest #'b (reverse rreq) '() '())) - (r (id? #'r) - (rest #'r (reverse rreq) '() '())) - (else - (syntax-violation 'lambda* "invalid argument list" orig-args args)))) - (define (opt args req ropt) - (syntax-case args () - (() - (check req (reverse ropt) #f '())) - ((a . b) (id? #'a) - (opt #'b req (cons #'(a #f) ropt))) - (((a init) . b) (id? #'a) - (opt #'b req (cons #'(a init) ropt))) - ((a . b) (eq? (syntax->datum #'a) #:key) - (key #'b req (reverse ropt) '())) - ((a b) (eq? (syntax->datum #'a) #:rest) - (rest #'b req (reverse ropt) '())) - (r (id? #'r) - (rest #'r req (reverse ropt) '())) - (else - (syntax-violation 'lambda* "invalid optional argument list" - orig-args args)))) - (define (key args req opt rkey) - (syntax-case args () - (() - (check req opt #f (cons #f (reverse rkey)))) - ((a . b) (id? #'a) - (with-syntax ((k (symbol->keyword (syntax->datum #'a)))) - (key #'b req opt (cons #'(k a #f) rkey)))) - (((a init) . b) (id? #'a) - (with-syntax ((k (symbol->keyword (syntax->datum #'a)))) - (key #'b req opt (cons #'(k a init) rkey)))) - (((a init k) . b) (and (id? #'a) - (keyword? (syntax->datum #'k))) - (key #'b req opt (cons #'(k a init) rkey))) - ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys) - (check req opt #f (cons #t (reverse rkey)))) - ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys) - (eq? (syntax->datum #'a) #:rest)) - (rest #'b req opt (cons #t (reverse rkey)))) - ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys) - (id? #'r)) - (rest #'r req opt (cons #t (reverse rkey)))) - ((a b) (eq? (syntax->datum #'a) #:rest) - (rest #'b req opt (cons #f (reverse rkey)))) - (r (id? #'r) - (rest #'r req opt (cons #f (reverse rkey)))) - (else - (syntax-violation 'lambda* "invalid keyword argument list" - orig-args args)))) - (define (rest args req opt kw) - (syntax-case args () - (r (id? #'r) - (check req opt #'r kw)) - (else - (syntax-violation 'lambda* "invalid rest argument" - orig-args args)))) - (define (check req opt rest kw) - (cond - ((distinct-bound-ids? - (append req (map car opt) (if rest (list rest) '()) - (if (pair? kw) (map cadr (cdr kw)) '()))) - (values req opt rest kw)) - (else - (syntax-violation 'lambda* "duplicate identifier in argument list" - orig-args)))) - (req orig-args '()))) - - (define expand-lambda-case - (lambda (e r w s mod get-formals clauses) - (define (parse-req req opt rest kw body) - (let ((vars (map gen-var req)) - (labels (gen-labels req))) - (let ((r* (extend-var-env labels vars r)) - (w* (make-binding-wrap req labels w))) - (parse-opt (map syntax->datum req) - opt rest kw body (reverse vars) r* w* '() '())))) - (define (parse-opt req opt rest kw body vars r* w* out inits) + ;; outer-form is fully wrapped w/source + (lambda (body outer-form r w mod) + (let* ((r (cons '("placeholder" . (placeholder)) r)) + (ribcage (make-empty-ribcage)) + (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) + (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) + (ids '()) (labels '()) + (var-ids '()) (vars '()) (vals '()) (bindings '()) + (expand-tail-expr #f)) (cond - ((pair? opt) - (syntax-case (car opt) () - ((id i) - (let* ((v (gen-var #'id)) - (l (gen-labels (list v))) - (r** (extend-var-env l (list v) r*)) - (w** (make-binding-wrap (list #'id) l w*))) - (parse-opt req (cdr opt) rest kw body (cons v vars) - r** w** (cons (syntax->datum #'id) out) - (cons (expand #'i r* w* mod) inits)))))) - (rest - (let* ((v (gen-var rest)) - (l (gen-labels (list v))) - (r* (extend-var-env l (list v) r*)) - (w* (make-binding-wrap (list rest) l w*))) - (parse-kw req (if (pair? out) (reverse out) #f) - (syntax->datum rest) - (if (pair? kw) (cdr kw) kw) - body (cons v vars) r* w* - (if (pair? kw) (car kw) #f) - '() inits))) + ((null? body) + (unless expand-tail-expr + (when (null? ids) + (syntax-violation #f "empty body" outer-form)) + (syntax-violation #f "body should end with an expression" outer-form)) + (unless (valid-bound-ids? ids) + (syntax-violation + #f "invalid or duplicate identifier in definition" + outer-form)) + (set-cdr! r (extend-env labels bindings (cdr r))) + (let ((src (source-annotation outer-form))) + (let lp ((var-ids var-ids) (vars vars) (vals vals) + (tail (expand-tail-expr))) + (cond + ((null? var-ids) tail) + ((not (car var-ids)) + (lp (cdr var-ids) (cdr vars) (cdr vals) + (make-seq src ((car vals)) tail))) + (else + (let ((var-ids (map (lambda (id) + (if id (syntax->datum id) '_)) + (reverse var-ids))) + (vars (map (lambda (var) (or var (gen-lexical '_))) + (reverse vars))) + (vals (map (lambda (expand-expr id) + (if id + (expand-expr) + (make-seq src + (expand-expr) + (build-void src)))) + (reverse vals) (reverse var-ids)))) + (build-letrec src #t var-ids vars vals tail))))))) + (expand-tail-expr + (parse body ids labels + (cons #f var-ids) + (cons #f vars) + (cons expand-tail-expr vals) + bindings #f)) (else - (parse-kw req (if (pair? out) (reverse out) #f) #f + (let ((e (cdar body)) (er (caar body)) (body (cdr body))) + (call-with-values + (lambda () (syntax-type e er empty-wrap (source-annotation e) ribcage mod #f)) + (lambda (type value form e w s mod) + (case type + ((define-form) + (let ((id (wrap value w mod)) (label (gen-label))) + (let ((var (gen-var id))) + (extend-ribcage! ribcage id label) + (parse body + (cons id ids) (cons label labels) + (cons id var-ids) + (cons var vars) + (cons (let ((wrapped (source-wrap e w s mod))) + (lambda () + (expand wrapped er empty-wrap mod))) + vals) + (cons (make-binding 'lexical var) bindings) + #f)))) + ((define-syntax-form) + (let ((id (wrap value w mod)) + (label (gen-label)) + (trans-r (macros-only-env er))) + (extend-ribcage! ribcage id label) + ;; As required by R6RS, evaluate the right-hand-sides of internal + ;; syntax definition forms and add their transformers to the + ;; compile-time environment immediately, so that the newly-defined + ;; keywords may be used in definition context within the same + ;; lexical contour. + (set-cdr! r (extend-env + (list label) + (list (make-binding + 'macro + (eval-local-transformer + (expand e trans-r w mod) + mod))) + (cdr r))) + (parse body (cons id ids) + labels var-ids vars vals bindings #f))) + ((define-syntax-parameter-form) + ;; Same as define-syntax-form, different binding type though. + (let ((id (wrap value w mod)) + (label (gen-label)) + (trans-r (macros-only-env er))) + (extend-ribcage! ribcage id label) + (set-cdr! r (extend-env + (list label) + (list (make-binding + 'syntax-parameter + (eval-local-transformer + (expand e trans-r w mod) + mod))) + (cdr r))) + (parse body (cons id ids) + labels var-ids vars vals bindings #f))) + ((begin-form) + (syntax-case e () + ((_ e1 ...) + (parse (let f ((forms #'(e1 ...))) + (if (null? forms) + body + (cons (cons er (wrap (car forms) w mod)) + (f (cdr forms))))) + ids labels var-ids vars vals bindings #f)))) + ((local-syntax-form) + (expand-local-syntax + value e er w s mod + (lambda (forms er w s mod) + (parse (let f ((forms forms)) + (if (null? forms) + body + (cons (cons er (wrap (car forms) w mod)) + (f (cdr forms))))) + ids labels var-ids vars vals bindings #f)))) + (else ; An expression, not a definition. + (let ((wrapped (source-wrap e w s mod))) + (parse body ids labels var-ids vars vals bindings + (lambda () + (expand wrapped er empty-wrap mod))))))))))))))) + + (define expand-local-syntax + (lambda (rec? e r w s mod k) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (let ((ids #'(id ...))) + (if (not (valid-bound-ids? ids)) + (syntax-violation #f "duplicate bound keyword" e) + (let ((labels (gen-labels ids))) + (let ((new-w (make-binding-wrap ids labels w))) + (k #'(e1 e2 ...) + (extend-env + labels + (let ((w (if rec? new-w w)) + (trans-r (macros-only-env r))) + (map (lambda (x) + (make-binding 'macro + (eval-local-transformer + (expand x trans-r w mod) + mod))) + #'(val ...))) + r) + new-w + s + mod)))))) + (_ (syntax-violation #f "bad local syntax definition" + (source-wrap e w s mod)))))) + + (define eval-local-transformer + (lambda (expanded mod) + (let ((p (local-eval expanded mod))) + (if (procedure? p) + p + (syntax-violation #f "nonprocedure transformer" p))))) + + (define expand-void + (lambda () + (build-void no-source))) + + (define ellipsis? + (lambda (e r mod) + (and (nonsymbol-id? e) + ;; If there is a binding for the special identifier + ;; #{ $sc-ellipsis }# in the lexical environment of E, + ;; and if the associated binding type is 'ellipsis', + ;; then the binding's value specifies the custom ellipsis + ;; identifier within that lexical environment, and the + ;; comparison is done using 'bound-id=?'. + (call-with-values + (lambda () (resolve-identifier + (make-syntax '#{ $sc-ellipsis }# + (syntax-wrap e) + (or (syntax-module e) mod) + #f) + empty-wrap r mod #f)) + (lambda (type value mod) + (if (eq? type 'ellipsis) + (bound-id=? e value) + (free-id=? e #'(... ...)))))))) + + (define lambda-formals + (lambda (orig-args) + (define (req args rreq) + (syntax-case args () + (() + (check (reverse rreq) #f)) + ((a . b) (id? #'a) + (req #'b (cons #'a rreq))) + (r (id? #'r) + (check (reverse rreq) #'r)) + (else + (syntax-violation 'lambda "invalid argument list" orig-args args)))) + (define (check req rest) + (cond + ((distinct-bound-ids? (if rest (cons rest req) req)) + (values req #f rest #f)) + (else + (syntax-violation 'lambda "duplicate identifier in argument list" + orig-args)))) + (req orig-args '()))) + + (define expand-simple-lambda + (lambda (e r w s mod req rest meta body) + (let* ((ids (if rest (append req (list rest)) req)) + (vars (map gen-var ids)) + (labels (gen-labels ids))) + (build-simple-lambda + s + (map syntax->datum req) (and rest (syntax->datum rest)) vars + meta + (expand-body body (source-wrap e w s mod) + (extend-var-env labels vars r) + (make-binding-wrap ids labels w) + mod))))) + + (define lambda*-formals + (lambda (orig-args) + (define (req args rreq) + (syntax-case args () + (() + (check (reverse rreq) '() #f '())) + ((a . b) (id? #'a) + (req #'b (cons #'a rreq))) + ((a . b) (eq? (syntax->datum #'a) #:optional) + (opt #'b (reverse rreq) '())) + ((a . b) (eq? (syntax->datum #'a) #:key) + (key #'b (reverse rreq) '() '())) + ((a b) (eq? (syntax->datum #'a) #:rest) + (rest #'b (reverse rreq) '() '())) + (r (id? #'r) + (rest #'r (reverse rreq) '() '())) + (else + (syntax-violation 'lambda* "invalid argument list" orig-args args)))) + (define (opt args req ropt) + (syntax-case args () + (() + (check req (reverse ropt) #f '())) + ((a . b) (id? #'a) + (opt #'b req (cons #'(a #f) ropt))) + (((a init) . b) (id? #'a) + (opt #'b req (cons #'(a init) ropt))) + ((a . b) (eq? (syntax->datum #'a) #:key) + (key #'b req (reverse ropt) '())) + ((a b) (eq? (syntax->datum #'a) #:rest) + (rest #'b req (reverse ropt) '())) + (r (id? #'r) + (rest #'r req (reverse ropt) '())) + (else + (syntax-violation 'lambda* "invalid optional argument list" + orig-args args)))) + (define (key args req opt rkey) + (syntax-case args () + (() + (check req opt #f (cons #f (reverse rkey)))) + ((a . b) (id? #'a) + (with-syntax ((k (symbol->keyword (syntax->datum #'a)))) + (key #'b req opt (cons #'(k a #f) rkey)))) + (((a init) . b) (id? #'a) + (with-syntax ((k (symbol->keyword (syntax->datum #'a)))) + (key #'b req opt (cons #'(k a init) rkey)))) + (((a init k) . b) (and (id? #'a) + (keyword? (syntax->datum #'k))) + (key #'b req opt (cons #'(k a init) rkey))) + ((aok) (eq? (syntax->datum #'aok) #:allow-other-keys) + (check req opt #f (cons #t (reverse rkey)))) + ((aok a b) (and (eq? (syntax->datum #'aok) #:allow-other-keys) + (eq? (syntax->datum #'a) #:rest)) + (rest #'b req opt (cons #t (reverse rkey)))) + ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys) + (id? #'r)) + (rest #'r req opt (cons #t (reverse rkey)))) + ((a b) (eq? (syntax->datum #'a) #:rest) + (rest #'b req opt (cons #f (reverse rkey)))) + (r (id? #'r) + (rest #'r req opt (cons #f (reverse rkey)))) + (else + (syntax-violation 'lambda* "invalid keyword argument list" + orig-args args)))) + (define (rest args req opt kw) + (syntax-case args () + (r (id? #'r) + (check req opt #'r kw)) + (else + (syntax-violation 'lambda* "invalid rest argument" + orig-args args)))) + (define (check req opt rest kw) + (cond + ((distinct-bound-ids? + (append req (map car opt) (if rest (list rest) '()) + (if (pair? kw) (map cadr (cdr kw)) '()))) + (values req opt rest kw)) + (else + (syntax-violation 'lambda* "duplicate identifier in argument list" + orig-args)))) + (req orig-args '()))) + + (define expand-lambda-case + (lambda (e r w s mod get-formals clauses) + (define (parse-req req opt rest kw body) + (let ((vars (map gen-var req)) + (labels (gen-labels req))) + (let ((r* (extend-var-env labels vars r)) + (w* (make-binding-wrap req labels w))) + (parse-opt (map syntax->datum req) + opt rest kw body (reverse vars) r* w* '() '())))) + (define (parse-opt req opt rest kw body vars r* w* out inits) + (cond + ((pair? opt) + (syntax-case (car opt) () + ((id i) + (let* ((v (gen-var #'id)) + (l (gen-labels (list v))) + (r** (extend-var-env l (list v) r*)) + (w** (make-binding-wrap (list #'id) l w*))) + (parse-opt req (cdr opt) rest kw body (cons v vars) + r** w** (cons (syntax->datum #'id) out) + (cons (expand #'i r* w* mod) inits)))))) + (rest + (let* ((v (gen-var rest)) + (l (gen-labels (list v))) + (r* (extend-var-env l (list v) r*)) + (w* (make-binding-wrap (list rest) l w*))) + (parse-kw req (if (pair? out) (reverse out) #f) + (syntax->datum rest) (if (pair? kw) (cdr kw) kw) - body vars r* w* + body (cons v vars) r* w* (if (pair? kw) (car kw) #f) - '() inits)))) - (define (parse-kw req opt rest kw body vars r* w* aok out inits) - (cond - ((pair? kw) - (syntax-case (car kw) () - ((k id i) - (let* ((v (gen-var #'id)) - (l (gen-labels (list v))) - (r** (extend-var-env l (list v) r*)) - (w** (make-binding-wrap (list #'id) l w*))) - (parse-kw req opt rest (cdr kw) body (cons v vars) - r** w** aok - (cons (list (syntax->datum #'k) - (syntax->datum #'id) - v) - out) - (cons (expand #'i r* w* mod) inits)))))) - (else - (parse-body req opt rest - (if (or aok (pair? out)) (cons aok (reverse out)) #f) - body (reverse vars) r* w* (reverse inits) '())))) - (define (parse-body req opt rest kw body vars r* w* inits meta) - (syntax-case body () - ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) - (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits - (append meta - `((documentation - . ,(syntax->datum #'docstring)))))) - ((#((k . v) ...) e1 e2 ...) - (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits - (append meta (syntax->datum #'((k . v) ...))))) - ((e1 e2 ...) - (values meta req opt rest kw inits vars - (expand-body #'(e1 e2 ...) (source-wrap e w s mod) - r* w* mod))))) - - (syntax-case clauses () - (() (values '() #f)) - (((args e1 e2 ...) (args* e1* e2* ...) ...) - (call-with-values (lambda () (get-formals #'args)) - (lambda (req opt rest kw) - (call-with-values (lambda () - (parse-req req opt rest kw #'(e1 e2 ...))) - (lambda (meta req opt rest kw inits vars body) - (call-with-values - (lambda () - (expand-lambda-case e r w s mod get-formals - #'((args* e1* e2* ...) ...))) - (lambda (meta* else*) - (values - (append meta meta*) - (build-lambda-case s req opt rest kw inits vars - body else*)))))))))))) - - ;; data - - ;; strips syntax objects, recursively. - - (define (strip x) - (define (annotate proc datum) - (let ((s (proc x))) - (when (and s (supports-source-properties? datum)) - (set-source-properties! datum (sourcev->alist s))) - datum)) - (cond - ((syntax? x) - (annotate syntax-sourcev (strip (syntax-expression x)))) - ((pair? x) - (cons (strip (car x)) (strip (cdr x)))) - ((vector? x) - (list->vector (strip (vector->list x)))) - (else x))) - - ;; lexical variables - - (define gen-var - (lambda (id) - (let ((id (if (syntax? id) (syntax-expression id) id))) - (gen-lexical id)))) - - ;; appears to return a reversed list - (define lambda-var-list - (lambda (vars) - (let lvl ((vars vars) (ls '()) (w empty-wrap)) - (cond - ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) - ((id? vars) (cons (wrap vars w #f) ls)) - ((null? vars) ls) - ((syntax? vars) - (lvl (syntax-expression vars) - ls - (join-wraps w (syntax-wrap vars)))) - ;; include anything else to be caught by subsequent error - ;; checking - (else (cons vars ls)))))) - - ;; core transformers - - (global-extend 'local-syntax 'letrec-syntax #t) - (global-extend 'local-syntax 'let-syntax #f) - - (global-extend - 'core 'syntax-parameterize - (lambda (e r w s mod) - (syntax-case e () - ((_ ((var val) ...) e1 e2 ...) - (valid-bound-ids? #'(var ...)) - (let ((names - (map (lambda (x) - (call-with-values - (lambda () (resolve-identifier x w r mod #f)) - (lambda (type value mod) - (case type - ((displaced-lexical) - (syntax-violation 'syntax-parameterize - "identifier out of context" - e - (source-wrap x w s mod))) - ((syntax-parameter) - value) - (else - (syntax-violation 'syntax-parameterize - "invalid syntax parameter" - e - (source-wrap x w s mod))))))) - #'(var ...))) - (bindings - (let ((trans-r (macros-only-env r))) - (map (lambda (x) - (make-binding - 'syntax-parameter - (eval-local-transformer (expand x trans-r w mod) mod))) - #'(val ...))))) - (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) - (extend-env names bindings r) - w - mod))) - (_ (syntax-violation 'syntax-parameterize "bad syntax" - (source-wrap e w s mod)))))) - - (global-extend 'core 'quote - (lambda (e r w s mod) - (syntax-case e () - ((_ e) (build-data s (strip #'e))) - (_ (syntax-violation 'quote "bad syntax" - (source-wrap e w s mod)))))) - - (global-extend 'core 'quote-syntax - (lambda (e r w s mod) - (syntax-case (source-wrap e w s mod) () - ((_ e) (build-data s #'e)) - (e (syntax-violation 'quote "bad syntax" #'e))))) - - (global-extend - 'core 'syntax - (let () - (define gen-syntax - (lambda (src e r maps ellipsis? mod) - (if (id? e) - (call-with-values (lambda () - (resolve-identifier e empty-wrap r mod #f)) - (lambda (type value mod) - (case type - ((syntax) + '() inits))) + (else + (parse-kw req (if (pair? out) (reverse out) #f) #f + (if (pair? kw) (cdr kw) kw) + body vars r* w* + (if (pair? kw) (car kw) #f) + '() inits)))) + (define (parse-kw req opt rest kw body vars r* w* aok out inits) + (cond + ((pair? kw) + (syntax-case (car kw) () + ((k id i) + (let* ((v (gen-var #'id)) + (l (gen-labels (list v))) + (r** (extend-var-env l (list v) r*)) + (w** (make-binding-wrap (list #'id) l w*))) + (parse-kw req opt rest (cdr kw) body (cons v vars) + r** w** aok + (cons (list (syntax->datum #'k) + (syntax->datum #'id) + v) + out) + (cons (expand #'i r* w* mod) inits)))))) + (else + (parse-body req opt rest + (if (or aok (pair? out)) (cons aok (reverse out)) #f) + body (reverse vars) r* w* (reverse inits) '())))) + (define (parse-body req opt rest kw body vars r* w* inits meta) + (syntax-case body () + ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) + (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits + (append meta + `((documentation + . ,(syntax->datum #'docstring)))))) + ((#((k . v) ...) e1 e2 ...) + (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits + (append meta (syntax->datum #'((k . v) ...))))) + ((e1 e2 ...) + (values meta req opt rest kw inits vars + (expand-body #'(e1 e2 ...) (source-wrap e w s mod) + r* w* mod))))) + + (syntax-case clauses () + (() (values '() #f)) + (((args e1 e2 ...) (args* e1* e2* ...) ...) + (call-with-values (lambda () (get-formals #'args)) + (lambda (req opt rest kw) + (call-with-values (lambda () + (parse-req req opt rest kw #'(e1 e2 ...))) + (lambda (meta req opt rest kw inits vars body) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod get-formals + #'((args* e1* e2* ...) ...))) + (lambda (meta* else*) + (values + (append meta meta*) + (build-lambda-case s req opt rest kw inits vars + body else*)))))))))))) + + ;; data + + ;; strips syntax objects, recursively. + + (define (strip x) + (define (annotate proc datum) + (let ((s (proc x))) + (when (and s (supports-source-properties? datum)) + (set-source-properties! datum (sourcev->alist s))) + datum)) + (cond + ((syntax? x) + (annotate syntax-sourcev (strip (syntax-expression x)))) + ((pair? x) + (cons (strip (car x)) (strip (cdr x)))) + ((vector? x) + (list->vector (strip (vector->list x)))) + (else x))) + + ;; lexical variables + + (define gen-var + (lambda (id) + (let ((id (if (syntax? id) (syntax-expression id) id))) + (gen-lexical id)))) + + ;; appears to return a reversed list + (define lambda-var-list + (lambda (vars) + (let lvl ((vars vars) (ls '()) (w empty-wrap)) + (cond + ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) + ((id? vars) (cons (wrap vars w #f) ls)) + ((null? vars) ls) + ((syntax? vars) + (lvl (syntax-expression vars) + ls + (join-wraps w (syntax-wrap vars)))) + ;; include anything else to be caught by subsequent error + ;; checking + (else (cons vars ls)))))) + + ;; core transformers + + (global-extend 'local-syntax 'letrec-syntax #t) + (global-extend 'local-syntax 'let-syntax #f) + + (global-extend + 'core 'syntax-parameterize + (lambda (e r w s mod) + (syntax-case e () + ((_ ((var val) ...) e1 e2 ...) + (valid-bound-ids? #'(var ...)) + (let ((names + (map (lambda (x) (call-with-values - (lambda () (gen-ref src (car value) (cdr value) maps)) - (lambda (var maps) - (values `(ref ,var) maps)))) - (else - (if (ellipsis? e r mod) - (syntax-violation 'syntax "misplaced ellipsis" src) - (values `(quote ,e) maps)))))) - (syntax-case e () - ((dots e) - (ellipsis? #'dots r mod) - (gen-syntax src #'e r maps (lambda (e r mod) #f) mod)) - ((x dots . y) - ;; this could be about a dozen lines of code, except that we - ;; choose to handle #'(x ... ...) forms - (ellipsis? #'dots r mod) - (let f ((y #'y) - (k (lambda (maps) - (call-with-values - (lambda () - (gen-syntax src #'x r - (cons '() maps) ellipsis? mod)) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" - src) - (values (gen-map x (car maps)) - (cdr maps)))))))) - (syntax-case y () - ((dots . y) - (ellipsis? #'dots r mod) - (f #'y - (lambda (maps) - (call-with-values - (lambda () (k (cons '() maps))) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" src) - (values (gen-mappend x (car maps)) - (cdr maps)))))))) - (_ (call-with-values - (lambda () (gen-syntax src y r maps ellipsis? mod)) - (lambda (y maps) + (lambda () (resolve-identifier x w r mod #f)) + (lambda (type value mod) + (case type + ((displaced-lexical) + (syntax-violation 'syntax-parameterize + "identifier out of context" + e + (source-wrap x w s mod))) + ((syntax-parameter) + value) + (else + (syntax-violation 'syntax-parameterize + "invalid syntax parameter" + e + (source-wrap x w s mod))))))) + #'(var ...))) + (bindings + (let ((trans-r (macros-only-env r))) + (map (lambda (x) + (make-binding + 'syntax-parameter + (eval-local-transformer (expand x trans-r w mod) mod))) + #'(val ...))))) + (expand-body #'(e1 e2 ...) + (source-wrap e w s mod) + (extend-env names bindings r) + w + mod))) + (_ (syntax-violation 'syntax-parameterize "bad syntax" + (source-wrap e w s mod)))))) + + (global-extend 'core 'quote + (lambda (e r w s mod) + (syntax-case e () + ((_ e) (build-data s (strip #'e))) + (_ (syntax-violation 'quote "bad syntax" + (source-wrap e w s mod)))))) + + (global-extend 'core 'quote-syntax + (lambda (e r w s mod) + (syntax-case (source-wrap e w s mod) () + ((_ e) (build-data s #'e)) + (e (syntax-violation 'quote "bad syntax" #'e))))) + + (global-extend + 'core 'syntax + (let () + (define gen-syntax + (lambda (src e r maps ellipsis? mod) + (if (id? e) + (call-with-values (lambda () + (resolve-identifier e empty-wrap r mod #f)) + (lambda (type value mod) + (case type + ((syntax) + (call-with-values + (lambda () (gen-ref src (car value) (cdr value) maps)) + (lambda (var maps) + (values `(ref ,var) maps)))) + (else + (if (ellipsis? e r mod) + (syntax-violation 'syntax "misplaced ellipsis" src) + (values `(quote ,e) maps)))))) + (syntax-case e () + ((dots e) + (ellipsis? #'dots r mod) + (gen-syntax src #'e r maps (lambda (e r mod) #f) mod)) + ((x dots . y) + ;; this could be about a dozen lines of code, except that we + ;; choose to handle #'(x ... ...) forms + (ellipsis? #'dots r mod) + (let f ((y #'y) + (k (lambda (maps) (call-with-values - (lambda () (k maps)) + (lambda () + (gen-syntax src #'x r + (cons '() maps) ellipsis? mod)) (lambda (x maps) - (values (gen-append x y) maps))))))))) - ((x . y) - (call-with-values - (lambda () (gen-syntax src #'x r maps ellipsis? mod)) - (lambda (x maps) - (call-with-values - (lambda () (gen-syntax src #'y r maps ellipsis? mod)) - (lambda (y maps) (values (gen-cons x y) maps)))))) - (#(e1 e2 ...) - (call-with-values - (lambda () - (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod)) - (lambda (e maps) (values (gen-vector e) maps)))) - (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps)) - (() (values '(quote ()) maps)) - (_ (values `(quote ,e) maps)))))) - - (define gen-ref - (lambda (src var level maps) - (if (= level 0) - (values var maps) - (if (null? maps) - (syntax-violation 'syntax "missing ellipsis" src) - (call-with-values - (lambda () (gen-ref src var (1- level) (cdr maps))) - (lambda (outer-var outer-maps) - (let ((b (assq outer-var (car maps)))) - (if b - (values (cdr b) maps) - (let ((inner-var (gen-var 'tmp))) - (values inner-var - (cons (cons (cons outer-var inner-var) - (car maps)) - outer-maps))))))))))) - - (define gen-mappend - (lambda (e map-env) - `(apply (primitive append) ,(gen-map e map-env)))) - - (define gen-map - (lambda (e map-env) - (let ((formals (map cdr map-env)) - (actuals (map (lambda (x) `(ref ,(car x))) map-env))) - (cond - ((eq? (car e) 'ref) - ;; identity map equivalence: - ;; (map (lambda (x) x) y) == y - (car actuals)) - ((and-map - (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) - (cdr e)) - ;; eta map equivalence: - ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) - `(map (primitive ,(car e)) - ,@(map (let ((r (map cons formals actuals))) - (lambda (x) (cdr (assq (cadr x) r)))) - (cdr e)))) - (else `(map (lambda ,formals ,e) ,@actuals)))))) - - (define gen-cons - (lambda (x y) - (case (car y) - ((quote) - (if (eq? (car x) 'quote) - `(quote (,(cadr x) . ,(cadr y))) - (if (eq? (cadr y) '()) - `(list ,x) - `(cons ,x ,y)))) - ((list) `(list ,x ,@(cdr y))) - (else `(cons ,x ,y))))) - - (define gen-append - (lambda (x y) - (if (equal? y '(quote ())) - x - `(append ,x ,y)))) - - (define gen-vector - (lambda (x) + (if (null? (car maps)) + (syntax-violation 'syntax "extra ellipsis" + src) + (values (gen-map x (car maps)) + (cdr maps)))))))) + (syntax-case y () + ((dots . y) + (ellipsis? #'dots r mod) + (f #'y + (lambda (maps) + (call-with-values + (lambda () (k (cons '() maps))) + (lambda (x maps) + (if (null? (car maps)) + (syntax-violation 'syntax "extra ellipsis" src) + (values (gen-mappend x (car maps)) + (cdr maps)))))))) + (_ (call-with-values + (lambda () (gen-syntax src y r maps ellipsis? mod)) + (lambda (y maps) + (call-with-values + (lambda () (k maps)) + (lambda (x maps) + (values (gen-append x y) maps))))))))) + ((x . y) + (call-with-values + (lambda () (gen-syntax src #'x r maps ellipsis? mod)) + (lambda (x maps) + (call-with-values + (lambda () (gen-syntax src #'y r maps ellipsis? mod)) + (lambda (y maps) (values (gen-cons x y) maps)))))) + (#(e1 e2 ...) + (call-with-values + (lambda () + (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod)) + (lambda (e maps) (values (gen-vector e) maps)))) + (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps)) + (() (values '(quote ()) maps)) + (_ (values `(quote ,e) maps)))))) + + (define gen-ref + (lambda (src var level maps) + (if (= level 0) + (values var maps) + (if (null? maps) + (syntax-violation 'syntax "missing ellipsis" src) + (call-with-values + (lambda () (gen-ref src var (1- level) (cdr maps))) + (lambda (outer-var outer-maps) + (let ((b (assq outer-var (car maps)))) + (if b + (values (cdr b) maps) + (let ((inner-var (gen-var 'tmp))) + (values inner-var + (cons (cons (cons outer-var inner-var) + (car maps)) + outer-maps))))))))))) + + (define gen-mappend + (lambda (e map-env) + `(apply (primitive append) ,(gen-map e map-env)))) + + (define gen-map + (lambda (e map-env) + (let ((formals (map cdr map-env)) + (actuals (map (lambda (x) `(ref ,(car x))) map-env))) (cond - ((eq? (car x) 'list) `(vector ,@(cdr x))) - ((eq? (car x) 'quote) `(quote #(,@(cadr x)))) - (else `(list->vector ,x))))) - - - (define regen - (lambda (x) - (case (car x) - ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) - ((primitive) (build-primref no-source (cadr x))) - ((quote) (build-data no-source (cadr x))) - ((lambda) - (if (list? (cadr x)) - (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) - (error "how did we get here" x))) - (else (build-primcall no-source (car x) (map regen (cdr x))))))) - - (lambda (e r w s mod) - (let ((e (source-wrap e w s mod))) - (syntax-case e () - ((_ x) - (call-with-values - (lambda () (gen-syntax e #'x r '() ellipsis? mod)) - (lambda (e maps) (regen e)))) - (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) + ((eq? (car e) 'ref) + ;; identity map equivalence: + ;; (map (lambda (x) x) y) == y + (car actuals)) + ((and-map + (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) + (cdr e)) + ;; eta map equivalence: + ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) + `(map (primitive ,(car e)) + ,@(map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e)))) + (else `(map (lambda ,formals ,e) ,@actuals)))))) + + (define gen-cons + (lambda (x y) + (case (car y) + ((quote) + (if (eq? (car x) 'quote) + `(quote (,(cadr x) . ,(cadr y))) + (if (eq? (cadr y) '()) + `(list ,x) + `(cons ,x ,y)))) + ((list) `(list ,x ,@(cdr y))) + (else `(cons ,x ,y))))) + + (define gen-append + (lambda (x y) + (if (equal? y '(quote ())) + x + `(append ,x ,y)))) + + (define gen-vector + (lambda (x) + (cond + ((eq? (car x) 'list) `(vector ,@(cdr x))) + ((eq? (car x) 'quote) `(quote #(,@(cadr x)))) + (else `(list->vector ,x))))) + + + (define regen + (lambda (x) + (case (car x) + ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) + ((primitive) (build-primref no-source (cadr x))) + ((quote) (build-data no-source (cadr x))) + ((lambda) + (if (list? (cadr x)) + (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) + (error "how did we get here" x))) + (else (build-primcall no-source (car x) (map regen (cdr x))))))) - (global-extend 'core 'lambda - (lambda (e r w s mod) - (syntax-case e () - ((_ args e1 e2 ...) - (call-with-values (lambda () (lambda-formals #'args)) - (lambda (req opt rest kw) - (let lp ((body #'(e1 e2 ...)) (meta '())) - (syntax-case body () - ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) - (lp #'(e1 e2 ...) - (append meta - `((documentation - . ,(syntax->datum #'docstring)))))) - ((#((k . v) ...) e1 e2 ...) - (lp #'(e1 e2 ...) - (append meta (syntax->datum #'((k . v) ...))))) - (_ (expand-simple-lambda e r w s mod req rest meta body))))))) - (_ (syntax-violation 'lambda "bad lambda" e))))) - - (global-extend 'core 'lambda* - (lambda (e r w s mod) - (syntax-case e () - ((_ args e1 e2 ...) - (call-with-values - (lambda () - (expand-lambda-case e r w s mod - lambda*-formals #'((args e1 e2 ...)))) - (lambda (meta lcase) - (build-case-lambda s meta lcase)))) - (_ (syntax-violation 'lambda "bad lambda*" e))))) + (lambda (e r w s mod) + (let ((e (source-wrap e w s mod))) + (syntax-case e () + ((_ x) + (call-with-values + (lambda () (gen-syntax e #'x r '() ellipsis? mod)) + (lambda (e maps) (regen e)))) + (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) - (global-extend 'core 'case-lambda - (lambda (e r w s mod) - (define (build-it meta clauses) - (call-with-values - (lambda () - (expand-lambda-case e r w s mod - lambda-formals - clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))) - (syntax-case e () - ((_ (args e1 e2 ...) ...) - (build-it '() #'((args e1 e2 ...) ...))) - ((_ docstring (args e1 e2 ...) ...) - (string? (syntax->datum #'docstring)) - (build-it `((documentation - . ,(syntax->datum #'docstring))) - #'((args e1 e2 ...) ...))) - (_ (syntax-violation 'case-lambda "bad case-lambda" e))))) - - (global-extend 'core 'case-lambda* - (lambda (e r w s mod) - (define (build-it meta clauses) - (call-with-values - (lambda () - (expand-lambda-case e r w s mod - lambda*-formals - clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))) - (syntax-case e () - ((_ (args e1 e2 ...) ...) - (build-it '() #'((args e1 e2 ...) ...))) - ((_ docstring (args e1 e2 ...) ...) - (string? (syntax->datum #'docstring)) - (build-it `((documentation - . ,(syntax->datum #'docstring))) - #'((args e1 e2 ...) ...))) - (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) - - (global-extend 'core 'with-ellipsis - (lambda (e r w s mod) - (syntax-case e () - ((_ dots e1 e2 ...) - (id? #'dots) - (let ((id (if (symbol? #'dots) - '#{ $sc-ellipsis }# - (make-syntax '#{ $sc-ellipsis }# - (syntax-wrap #'dots) - (syntax-module #'dots) - (syntax-sourcev #'dots))))) - (let ((ids (list id)) - (labels (list (gen-label))) - (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-env labels bindings r))) - (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod))))) - (_ (syntax-violation 'with-ellipsis "bad syntax" - (source-wrap e w s mod)))))) - - (global-extend 'core 'let - (let () - (define (expand-let e r w s mod constructor ids vals exps) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'let "duplicate bound variable" e) - (let ((labels (gen-labels ids)) - (new-vars (map gen-var ids))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-var-env labels new-vars r))) - (constructor s - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) vals) - (expand-body exps (source-wrap e nw s mod) - nr nw mod)))))) - (lambda (e r w s mod) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (and-map id? #'(id ...)) - (expand-let e r w s mod - build-let - #'(id ...) - #'(val ...) - #'(e1 e2 ...))) - ((_ f ((id val) ...) e1 e2 ...) - (and (id? #'f) (and-map id? #'(id ...))) - (expand-let e r w s mod - build-named-let - #'(f id ...) - #'(val ...) - #'(e1 e2 ...))) - (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) - - - (global-extend 'core 'letrec - (lambda (e r w s mod) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (and-map id? #'(id ...)) - (let ((ids #'(id ...))) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec "duplicate bound variable" e) - (let ((labels (gen-labels ids)) - (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) - (r (extend-var-env labels new-vars r))) - (build-letrec s #f - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) #'(val ...)) - (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) r w mod))))))) - (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) - - - (global-extend 'core 'letrec* + (global-extend 'core 'lambda + (lambda (e r w s mod) + (syntax-case e () + ((_ args e1 e2 ...) + (call-with-values (lambda () (lambda-formals #'args)) + (lambda (req opt rest kw) + (let lp ((body #'(e1 e2 ...)) (meta '())) + (syntax-case body () + ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) + (lp #'(e1 e2 ...) + (append meta + `((documentation + . ,(syntax->datum #'docstring)))))) + ((#((k . v) ...) e1 e2 ...) + (lp #'(e1 e2 ...) + (append meta (syntax->datum #'((k . v) ...))))) + (_ (expand-simple-lambda e r w s mod req rest meta body))))))) + (_ (syntax-violation 'lambda "bad lambda" e))))) + + (global-extend 'core 'lambda* + (lambda (e r w s mod) + (syntax-case e () + ((_ args e1 e2 ...) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod + lambda*-formals #'((args e1 e2 ...)))) + (lambda (meta lcase) + (build-case-lambda s meta lcase)))) + (_ (syntax-violation 'lambda "bad lambda*" e))))) + + (global-extend 'core 'case-lambda + (lambda (e r w s mod) + (define (build-it meta clauses) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod + lambda-formals + clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))) + (syntax-case e () + ((_ (args e1 e2 ...) ...) + (build-it '() #'((args e1 e2 ...) ...))) + ((_ docstring (args e1 e2 ...) ...) + (string? (syntax->datum #'docstring)) + (build-it `((documentation + . ,(syntax->datum #'docstring))) + #'((args e1 e2 ...) ...))) + (_ (syntax-violation 'case-lambda "bad case-lambda" e))))) + + (global-extend 'core 'case-lambda* + (lambda (e r w s mod) + (define (build-it meta clauses) + (call-with-values + (lambda () + (expand-lambda-case e r w s mod + lambda*-formals + clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))) + (syntax-case e () + ((_ (args e1 e2 ...) ...) + (build-it '() #'((args e1 e2 ...) ...))) + ((_ docstring (args e1 e2 ...) ...) + (string? (syntax->datum #'docstring)) + (build-it `((documentation + . ,(syntax->datum #'docstring))) + #'((args e1 e2 ...) ...))) + (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) + + (global-extend 'core 'with-ellipsis + (lambda (e r w s mod) + (syntax-case e () + ((_ dots e1 e2 ...) + (id? #'dots) + (let ((id (if (symbol? #'dots) + '#{ $sc-ellipsis }# + (make-syntax '#{ $sc-ellipsis }# + (syntax-wrap #'dots) + (syntax-module #'dots) + (syntax-sourcev #'dots))))) + (let ((ids (list id)) + (labels (list (gen-label))) + (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-env labels bindings r))) + (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod))))) + (_ (syntax-violation 'with-ellipsis "bad syntax" + (source-wrap e w s mod)))))) + + (global-extend 'core 'let + (let () + (define (expand-let e r w s mod constructor ids vals exps) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'let "duplicate bound variable" e) + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-var-env labels new-vars r))) + (constructor s + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) vals) + (expand-body exps (source-wrap e nw s mod) + nr nw mod)))))) (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) (and-map id? #'(id ...)) - (let ((ids #'(id ...))) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec* "duplicate bound variable" e) - (let ((labels (gen-labels ids)) - (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) - (r (extend-var-env labels new-vars r))) - (build-letrec s #t - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) #'(val ...)) - (expand-body #'(e1 e2 ...) - (source-wrap e w s mod) r w mod))))))) - (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) - - - (global-extend - 'core 'set! - (lambda (e r w s mod) - (syntax-case e () - ((_ id val) - (id? #'id) - (call-with-values - (lambda () (resolve-identifier #'id w r mod #t)) - (lambda (type value id-mod) - (case type - ((lexical) - (build-lexical-assignment s (syntax->datum #'id) value - (expand #'val r w mod))) - ((global) - (build-global-assignment s value (expand #'val r w mod) id-mod)) - ((macro) - (if (procedure-property value 'variable-transformer) - ;; As syntax-type does, call expand-macro with - ;; the mod of the expression. Hmm. - (expand (expand-macro value e r w s #f mod) r empty-wrap mod) - (syntax-violation 'set! "not a variable transformer" - (wrap e w mod) - (wrap #'id w id-mod)))) - ((displaced-lexical) - (syntax-violation 'set! "identifier out of context" - (wrap #'id w mod))) - (else - (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))) - ((_ (head tail ...) val) - (call-with-values - (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t)) - (lambda (type value ee* ee ww ss modmod) - (case type - ((module-ref) - (let ((val (expand #'val r w mod))) - (call-with-values (lambda () (value #'(head tail ...) r w mod)) - (lambda (e r w s* mod) - (syntax-case e () - (e (id? #'e) - (build-global-assignment s (syntax->datum #'e) - val mod))))))) - (else - (build-call s - (expand #'(setter head) r w mod) - (map (lambda (e) (expand e r w mod)) - #'(tail ... val)))))))) - (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) - - (global-extend 'module-ref '@ - (lambda (e r w mod) + (expand-let e r w s mod + build-let + #'(id ...) + #'(val ...) + #'(e1 e2 ...))) + ((_ f ((id val) ...) e1 e2 ...) + (and (id? #'f) (and-map id? #'(id ...))) + (expand-let e r w s mod + build-named-let + #'(f id ...) + #'(val ...) + #'(e1 e2 ...))) + (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) + + + (global-extend 'core 'letrec + (lambda (e r w s mod) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (and-map id? #'(id ...)) + (let ((ids #'(id ...))) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec "duplicate bound variable" e) + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec s #f + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) #'(val ...)) + (expand-body #'(e1 e2 ...) + (source-wrap e w s mod) r w mod))))))) + (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) + + + (global-extend 'core 'letrec* + (lambda (e r w s mod) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (and-map id? #'(id ...)) + (let ((ids #'(id ...))) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec* "duplicate bound variable" e) + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec s #t + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) #'(val ...)) + (expand-body #'(e1 e2 ...) + (source-wrap e w s mod) r w mod))))))) + (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) + + + (global-extend + 'core 'set! + (lambda (e r w s mod) + (syntax-case e () + ((_ id val) + (id? #'id) + (call-with-values + (lambda () (resolve-identifier #'id w r mod #t)) + (lambda (type value id-mod) + (case type + ((lexical) + (build-lexical-assignment s (syntax->datum #'id) value + (expand #'val r w mod))) + ((global) + (build-global-assignment s value (expand #'val r w mod) id-mod)) + ((macro) + (if (procedure-property value 'variable-transformer) + ;; As syntax-type does, call expand-macro with + ;; the mod of the expression. Hmm. + (expand (expand-macro value e r w s #f mod) r empty-wrap mod) + (syntax-violation 'set! "not a variable transformer" + (wrap e w mod) + (wrap #'id w id-mod)))) + ((displaced-lexical) + (syntax-violation 'set! "identifier out of context" + (wrap #'id w mod))) + (else + (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))) + ((_ (head tail ...) val) + (call-with-values + (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t)) + (lambda (type value ee* ee ww ss modmod) + (case type + ((module-ref) + (let ((val (expand #'val r w mod))) + (call-with-values (lambda () (value #'(head tail ...) r w mod)) + (lambda (e r w s* mod) (syntax-case e () - ((_ (mod ...) id) - (and (and-map id? #'(mod ...)) (id? #'id)) - ;; Strip the wrap from the identifier and return top-wrap - ;; so that the identifier will not be captured by lexicals. - (values (syntax->datum #'id) r top-wrap #f - (syntax->datum - #'(public mod ...))))))) - - (global-extend 'module-ref '@@ - (lambda (e r w mod) - (define remodulate - (lambda (x mod) - (cond ((pair? x) - (cons (remodulate (car x) mod) - (remodulate (cdr x) mod))) - ((syntax? x) - (make-syntax - (remodulate (syntax-expression x) mod) - (syntax-wrap x) - ;; hither the remodulation - mod - (syntax-sourcev x))) - ((vector? x) - (let* ((n (vector-length x)) (v (make-vector n))) - (do ((i 0 (1+ i))) - ((= i n) v) - (vector-set! v i (remodulate (vector-ref x i) mod))))) - (else x)))) - (syntax-case e (@@ primitive) - ((_ primitive id) - (and (id? #'id) - (equal? (cdr (or (and (syntax? #'id) - (syntax-module #'id)) - mod)) - '(guile))) - ;; Strip the wrap from the identifier and return top-wrap - ;; so that the identifier will not be captured by lexicals. - (values (syntax->datum #'id) r top-wrap #f '(primitive))) - ((_ (mod ...) id) - (and (and-map id? #'(mod ...)) (id? #'id)) - ;; Strip the wrap from the identifier and return top-wrap - ;; so that the identifier will not be captured by lexicals. - (values (syntax->datum #'id) r top-wrap #f - (syntax->datum - #'(private mod ...)))) - ((_ @@ (mod ...) exp) - (and-map id? #'(mod ...)) - ;; This is a special syntax used to support R6RS library forms. - ;; Unlike the syntax above, the last item is not restricted to - ;; be a single identifier, and the syntax objects are kept - ;; intact, with only their module changed. - (let ((mod (syntax->datum #'(private mod ...)))) - (values (remodulate #'exp mod) - r w (source-annotation #'exp) - mod)))))) + (e (id? #'e) + (build-global-assignment s (syntax->datum #'e) + val mod))))))) + (else + (build-call s + (expand #'(setter head) r w mod) + (map (lambda (e) (expand e r w mod)) + #'(tail ... val)))))))) + (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) + + (global-extend 'module-ref '@ + (lambda (e r w mod) + (syntax-case e () + ((_ (mod ...) id) + (and (and-map id? #'(mod ...)) (id? #'id)) + ;; Strip the wrap from the identifier and return top-wrap + ;; so that the identifier will not be captured by lexicals. + (values (syntax->datum #'id) r top-wrap #f + (syntax->datum + #'(public mod ...))))))) + + (global-extend 'module-ref '@@ + (lambda (e r w mod) + (define remodulate + (lambda (x mod) + (cond ((pair? x) + (cons (remodulate (car x) mod) + (remodulate (cdr x) mod))) + ((syntax? x) + (make-syntax + (remodulate (syntax-expression x) mod) + (syntax-wrap x) + ;; hither the remodulation + mod + (syntax-sourcev x))) + ((vector? x) + (let* ((n (vector-length x)) (v (make-vector n))) + (do ((i 0 (1+ i))) + ((= i n) v) + (vector-set! v i (remodulate (vector-ref x i) mod))))) + (else x)))) + (syntax-case e (@@ primitive) + ((_ primitive id) + (and (id? #'id) + (equal? (cdr (or (and (syntax? #'id) + (syntax-module #'id)) + mod)) + '(guile))) + ;; Strip the wrap from the identifier and return top-wrap + ;; so that the identifier will not be captured by lexicals. + (values (syntax->datum #'id) r top-wrap #f '(primitive))) + ((_ (mod ...) id) + (and (and-map id? #'(mod ...)) (id? #'id)) + ;; Strip the wrap from the identifier and return top-wrap + ;; so that the identifier will not be captured by lexicals. + (values (syntax->datum #'id) r top-wrap #f + (syntax->datum + #'(private mod ...)))) + ((_ @@ (mod ...) exp) + (and-map id? #'(mod ...)) + ;; This is a special syntax used to support R6RS library forms. + ;; Unlike the syntax above, the last item is not restricted to + ;; be a single identifier, and the syntax objects are kept + ;; intact, with only their module changed. + (let ((mod (syntax->datum #'(private mod ...)))) + (values (remodulate #'exp mod) + r w (source-annotation #'exp) + mod)))))) - (global-extend 'core 'if + (global-extend 'core 'if + (lambda (e r w s mod) + (syntax-case e () + ((_ test then) + (build-conditional + s + (expand #'test r w mod) + (expand #'then r w mod) + (build-void no-source))) + ((_ test then else) + (build-conditional + s + (expand #'test r w mod) + (expand #'then r w mod) + (expand #'else r w mod)))))) + + (global-extend 'begin 'begin '()) + + (global-extend 'define 'define '()) + + (global-extend 'define-syntax 'define-syntax '()) + (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) + + (global-extend 'eval-when 'eval-when '()) + + (global-extend 'core 'syntax-case + (let () + (define convert-pattern + ;; accepts pattern & keys + ;; returns $sc-dispatch pattern & ids + (lambda (pattern keys ellipsis?) + (define cvt* + (lambda (p* n ids) + (syntax-case p* () + ((x . y) + (call-with-values + (lambda () (cvt* #'y n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt #'x n ids)) + (lambda (x ids) + (values (cons x y) ids)))))) + (_ (cvt p* n ids))))) + + (define (v-reverse x) + (let loop ((r '()) (x x)) + (if (not (pair? x)) + (values r x) + (loop (cons (car x) r) (cdr x))))) + + (define cvt + (lambda (p n ids) + (if (id? p) + (cond + ((bound-id-member? p keys) + (values (vector 'free-id p) ids)) + ((free-id=? p #'_) + (values '_ ids)) + (else + (values 'any (cons (cons p n) ids)))) + (syntax-case p () + ((x dots) + (ellipsis? (syntax dots)) + (call-with-values + (lambda () (cvt (syntax x) (1+ n) ids)) + (lambda (p ids) + (values (if (eq? p 'any) 'each-any (vector 'each p)) + ids)))) + ((x dots . ys) + (ellipsis? (syntax dots)) + (call-with-values + (lambda () (cvt* (syntax ys) n ids)) + (lambda (ys ids) + (call-with-values + (lambda () (cvt (syntax x) (+ n 1) ids)) + (lambda (x ids) + (call-with-values + (lambda () (v-reverse ys)) + (lambda (ys e) + (values `#(each+ ,x ,ys ,e) + ids)))))))) + ((x . y) + (call-with-values + (lambda () (cvt (syntax y) n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt (syntax x) n ids)) + (lambda (x ids) + (values (cons x y) ids)))))) + (() (values '() ids)) + (#(x ...) + (call-with-values + (lambda () (cvt (syntax (x ...)) n ids)) + (lambda (p ids) (values (vector 'vector p) ids)))) + (x (values (vector 'atom (strip p)) ids)))))) + (cvt pattern 0 '()))) + + (define build-dispatch-call + (lambda (pvars exp y r mod) + (let ((ids (map car pvars)) (levels (map cdr pvars))) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (build-primcall + no-source + 'apply + (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() + (expand exp + (extend-env + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) + y)))))) + + (define gen-clause + (lambda (x keys clauses r pat fender exp mod) + (call-with-values + (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) + (lambda (p pvars) + (cond + ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) + ((not (distinct-bound-ids? (map car pvars))) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + (else + (let ((y (gen-var 'tmp))) + ;; fat finger binding and references to temp variable y + (build-call no-source + (build-simple-lambda no-source (list 'tmp) #f (list y) '() + (let ((y (build-lexical-reference 'value no-source + 'tmp y))) + (build-conditional no-source + (syntax-case fender () + (#t y) + (_ (build-conditional no-source + y + (build-dispatch-call pvars fender y r mod) + (build-data no-source #f)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) + (list (if (eq? p 'any) + (build-primcall no-source 'list (list x)) + (build-primcall no-source '$sc-dispatch + (list x (build-data no-source p))))))))))))) + + (define gen-syntax-case + (lambda (x keys clauses r mod) + (if (null? clauses) + (build-primcall no-source 'syntax-violation + (list (build-data no-source #f) + (build-data no-source + "source expression failed to match any pattern") + x)) + (syntax-case (car clauses) () + ((pat exp) + (if (and (id? #'pat) + (and-map (lambda (x) (not (free-id=? #'pat x))) + (cons #'(... ...) keys))) + (if (free-id=? #'pat #'_) + (expand #'exp r empty-wrap mod) + (let ((labels (list (gen-label))) + (var (gen-var #'pat))) + (build-call no-source + (build-simple-lambda + no-source (list (syntax->datum #'pat)) #f (list var) + '() + (expand #'exp + (extend-env labels + (list (make-binding 'syntax `(,var . 0))) + r) + (make-binding-wrap #'(pat) + labels empty-wrap) + mod)) + (list x)))) + (gen-clause x keys (cdr clauses) r + #'pat #t #'exp mod))) + ((pat fender exp) + (gen-clause x keys (cdr clauses) r + #'pat #'fender #'exp mod)) + (_ (syntax-violation 'syntax-case "invalid clause" + (car clauses))))))) + (lambda (e r w s mod) - (syntax-case e () - ((_ test then) - (build-conditional - s - (expand #'test r w mod) - (expand #'then r w mod) - (build-void no-source))) - ((_ test then else) - (build-conditional - s - (expand #'test r w mod) - (expand #'then r w mod) - (expand #'else r w mod)))))) - - (global-extend 'begin 'begin '()) - - (global-extend 'define 'define '()) - - (global-extend 'define-syntax 'define-syntax '()) - (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) - - (global-extend 'eval-when 'eval-when '()) - - (global-extend 'core 'syntax-case - (let () - (define convert-pattern - ;; accepts pattern & keys - ;; returns $sc-dispatch pattern & ids - (lambda (pattern keys ellipsis?) - (define cvt* - (lambda (p* n ids) - (syntax-case p* () - ((x . y) - (call-with-values - (lambda () (cvt* #'y n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt #'x n ids)) - (lambda (x ids) - (values (cons x y) ids)))))) - (_ (cvt p* n ids))))) - - (define (v-reverse x) - (let loop ((r '()) (x x)) - (if (not (pair? x)) - (values r x) - (loop (cons (car x) r) (cdr x))))) - - (define cvt - (lambda (p n ids) - (if (id? p) - (cond - ((bound-id-member? p keys) - (values (vector 'free-id p) ids)) - ((free-id=? p #'_) - (values '_ ids)) - (else - (values 'any (cons (cons p n) ids)))) - (syntax-case p () - ((x dots) - (ellipsis? (syntax dots)) - (call-with-values - (lambda () (cvt (syntax x) (1+ n) ids)) - (lambda (p ids) - (values (if (eq? p 'any) 'each-any (vector 'each p)) - ids)))) - ((x dots . ys) - (ellipsis? (syntax dots)) - (call-with-values - (lambda () (cvt* (syntax ys) n ids)) - (lambda (ys ids) - (call-with-values - (lambda () (cvt (syntax x) (+ n 1) ids)) - (lambda (x ids) - (call-with-values - (lambda () (v-reverse ys)) - (lambda (ys e) - (values `#(each+ ,x ,ys ,e) - ids)))))))) - ((x . y) - (call-with-values - (lambda () (cvt (syntax y) n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt (syntax x) n ids)) - (lambda (x ids) - (values (cons x y) ids)))))) - (() (values '() ids)) - (#(x ...) - (call-with-values - (lambda () (cvt (syntax (x ...)) n ids)) - (lambda (p ids) (values (vector 'vector p) ids)))) - (x (values (vector 'atom (strip p)) ids)))))) - (cvt pattern 0 '()))) - - (define build-dispatch-call - (lambda (pvars exp y r mod) - (let ((ids (map car pvars)) (levels (map cdr pvars))) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-primcall - no-source - 'apply - (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() - (expand exp - (extend-env - labels - (map (lambda (var level) - (make-binding 'syntax `(,var . ,level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap) - mod)) - y)))))) - - (define gen-clause - (lambda (x keys clauses r pat fender exp mod) - (call-with-values - (lambda () (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) - (lambda (p pvars) - (cond - ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) - (syntax-violation 'syntax-case "misplaced ellipsis" pat)) - ((not (distinct-bound-ids? (map car pvars))) - (syntax-violation 'syntax-case "duplicate pattern variable" pat)) - (else - (let ((y (gen-var 'tmp))) - ;; fat finger binding and references to temp variable y - (build-call no-source - (build-simple-lambda no-source (list 'tmp) #f (list y) '() - (let ((y (build-lexical-reference 'value no-source - 'tmp y))) - (build-conditional no-source - (syntax-case fender () - (#t y) - (_ (build-conditional no-source - y - (build-dispatch-call pvars fender y r mod) - (build-data no-source #f)))) - (build-dispatch-call pvars exp y r mod) - (gen-syntax-case x keys clauses r mod)))) - (list (if (eq? p 'any) - (build-primcall no-source 'list (list x)) - (build-primcall no-source '$sc-dispatch - (list x (build-data no-source p))))))))))))) - - (define gen-syntax-case - (lambda (x keys clauses r mod) - (if (null? clauses) - (build-primcall no-source 'syntax-violation - (list (build-data no-source #f) - (build-data no-source - "source expression failed to match any pattern") - x)) - (syntax-case (car clauses) () - ((pat exp) - (if (and (id? #'pat) - (and-map (lambda (x) (not (free-id=? #'pat x))) - (cons #'(... ...) keys))) - (if (free-id=? #'pat #'_) - (expand #'exp r empty-wrap mod) - (let ((labels (list (gen-label))) - (var (gen-var #'pat))) - (build-call no-source - (build-simple-lambda - no-source (list (syntax->datum #'pat)) #f (list var) - '() - (expand #'exp - (extend-env labels - (list (make-binding 'syntax `(,var . 0))) - r) - (make-binding-wrap #'(pat) - labels empty-wrap) - mod)) - (list x)))) - (gen-clause x keys (cdr clauses) r - #'pat #t #'exp mod))) - ((pat fender exp) - (gen-clause x keys (cdr clauses) r - #'pat #'fender #'exp mod)) - (_ (syntax-violation 'syntax-case "invalid clause" - (car clauses))))))) - - (lambda (e r w s mod) - (let ((e (source-wrap e w s mod))) - (syntax-case e () - ((_ val (key ...) m ...) - (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) - #'(key ...)) - (let ((x (gen-var 'tmp))) - ;; fat finger binding and references to temp variable x - (build-call s - (build-simple-lambda no-source (list 'tmp) #f (list x) '() - (gen-syntax-case (build-lexical-reference 'value no-source - 'tmp x) - #'(key ...) #'(m ...) - r - mod)) - (list (expand #'val r empty-wrap mod)))) - (syntax-violation 'syntax-case "invalid literals list" e)))))))) - - ;; The portable macroexpand seeds expand-top's mode m with 'e (for - ;; evaluating) and esew (which stands for "eval syntax expanders - ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e - ;; if we are compiling a file, and esew is set to - ;; (eval-syntactic-expanders-when), which defaults to the list - ;; '(compile load eval). This means that, by default, top-level - ;; syntactic definitions are evaluated immediately after they are - ;; expanded, and the expanded definitions are also residualized into - ;; the object file if we are compiling a file. - (set! macroexpand - (lambda* (x #:optional (m 'e) (esew '(eval))) - (define (unstrip x) - (define (annotate result) - (let ((props (source-properties x))) - (if (pair? props) - (datum->syntax #f result #:source props) - result))) - (cond - ((pair? x) - (annotate (cons (unstrip (car x)) (unstrip (cdr x))))) - ((vector? x) - (let ((v (make-vector (vector-length x)))) - (annotate (list->vector (map unstrip (vector->list x)))))) - ((syntax? x) x) - (else (annotate x)))) - (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew - (cons 'hygiene (module-name (current-module)))))) - - (set! identifier? - (lambda (x) - (nonsymbol-id? x))) - - (set! datum->syntax - (lambda* (id datum #:key source) - (define (props->sourcev alist) - (and (pair? alist) - (vector (assq-ref alist 'filename) - (assq-ref alist 'line) - (assq-ref alist 'column)))) - (make-syntax datum - (if id - (syntax-wrap id) - empty-wrap) - (if id - (syntax-module id) - #f) - (cond - ((not source) - (props->sourcev (source-properties datum))) - ((and (list? source) (and-map pair? source)) - (props->sourcev source)) - ((and (vector? source) (= 3 (vector-length source))) - source) - (else (syntax-sourcev source)))))) - - (set! syntax->datum - ;; accepts any object, since syntax objects may consist partially - ;; or entirely of unwrapped, nonsymbolic data - (lambda (x) - (strip x))) - - (set! generate-temporaries - (lambda (ls) - (arg-check list? ls 'generate-temporaries) - (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) - (wrap (gen-var 't) top-wrap mod)) - ls)))) - - (set! free-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'free-identifier=?) - (arg-check nonsymbol-id? y 'free-identifier=?) - (free-id=? x y))) - - (set! bound-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'bound-identifier=?) - (arg-check nonsymbol-id? y 'bound-identifier=?) - (bound-id=? x y))) - - (set! syntax-violation - (lambda* (who message form #:optional subform) - (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) - who 'syntax-violation) - (arg-check string? message 'syntax-violation) - (throw 'syntax-error who message - (sourcev->alist - (or (source-annotation subform) - (source-annotation form))) - (strip form) - (strip subform)))) - - (let () - (define (%syntax-module id) - (arg-check nonsymbol-id? id 'syntax-module) - (let ((mod (syntax-module id))) - (and mod - (not (equal? mod '(primitive))) - (cdr mod)))) - - (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t)) - (arg-check nonsymbol-id? id 'syntax-local-binding) - (with-transformer-environment - (lambda (e r w s rib mod) - (define (strip-anti-mark w) - (let ((ms (wrap-marks w)) (s (wrap-subst w))) - (if (and (pair? ms) (eq? (car ms) the-anti-mark)) - ;; output is from original text - (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) - ;; output introduced by macro - (make-wrap ms (if rib (cons rib s) s))))) - (call-with-values (lambda () - (resolve-identifier - (syntax-expression id) - (strip-anti-mark (syntax-wrap id)) - r - (or (syntax-module id) mod) - resolve-syntax-parameters?)) - (lambda (type value mod) - (case type - ((lexical) (values 'lexical value)) - ((macro) (values 'macro value)) - ((syntax-parameter) (values 'syntax-parameter value)) - ((syntax) (values 'pattern-variable value)) - ((displaced-lexical) (values 'displaced-lexical #f)) - ((global) - (if (equal? mod '(primitive)) - (values 'primitive value) - (values 'global (cons value (cdr mod))))) - ((ellipsis) - (values 'ellipsis - (wrap-syntax value (anti-mark (syntax-wrap value)) - mod))) - (else (values 'other #f)))))))) - - (define (syntax-locally-bound-identifiers id) - (arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers) - (locally-bound-identifiers (syntax-wrap id) - (syntax-module id))) - - ;; Using define! instead of set! to avoid warnings at - ;; compile-time, after the variables are stolen away into (system - ;; syntax). See the end of boot-9.scm. - ;; - (define! '%syntax-module %syntax-module) - (define! 'syntax-local-binding syntax-local-binding) - (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers)) - - ;; $sc-dispatch expects an expression and a pattern. If the expression - ;; matches the pattern a list of the matching expressions for each - ;; "any" is returned. Otherwise, #f is returned. (This use of #f will - ;; not work on r4rs implementations that violate the ieee requirement - ;; that #f and () be distinct.) - - ;; The expression is matched with the pattern as follows: - - ;; pattern: matches: - ;; () empty list - ;; any anything - ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2) - ;; each-any (any*) - ;; #(free-id <key>) <key> with free-identifier=? - ;; #(each <pattern>) (<pattern>*) - ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) - ;; #(vector <pattern>) (list->vector <pattern>) - ;; #(atom <object>) <object> with "equal?" - - ;; Vector cops out to pair under assumption that vectors are rare. If - ;; not, should convert to: - ;; #(vector <pattern>*) #(<pattern>*) - - (let () - - (define match-each - (lambda (e p w mod) - (cond - ((pair? e) - (let ((first (match (car e) p w '() mod))) - (and first - (let ((rest (match-each (cdr e) p w mod))) - (and rest (cons first rest)))))) - ((null? e) '()) - ((syntax? e) - (match-each (syntax-expression e) - p - (join-wraps w (syntax-wrap e)) - (or (syntax-module e) mod))) - (else #f)))) - - (define match-each+ - (lambda (e x-pat y-pat z-pat w r mod) - (let f ((e e) (w w)) + (let ((e (source-wrap e w s mod))) + (syntax-case e () + ((_ val (key ...) m ...) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) + #'(key ...)) + (let ((x (gen-var 'tmp))) + ;; fat finger binding and references to temp variable x + (build-call s + (build-simple-lambda no-source (list 'tmp) #f (list x) '() + (gen-syntax-case (build-lexical-reference 'value no-source + 'tmp x) + #'(key ...) #'(m ...) + r + mod)) + (list (expand #'val r empty-wrap mod)))) + (syntax-violation 'syntax-case "invalid literals list" e)))))))) + + ;; The portable macroexpand seeds expand-top's mode m with 'e (for + ;; evaluating) and esew (which stands for "eval syntax expanders + ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e + ;; if we are compiling a file, and esew is set to + ;; (eval-syntactic-expanders-when), which defaults to the list + ;; '(compile load eval). This means that, by default, top-level + ;; syntactic definitions are evaluated immediately after they are + ;; expanded, and the expanded definitions are also residualized into + ;; the object file if we are compiling a file. + (set! macroexpand + (lambda* (x #:optional (m 'e) (esew '(eval))) + (define (unstrip x) + (define (annotate result) + (let ((props (source-properties x))) + (if (pair? props) + (datum->syntax #f result #:source props) + result))) (cond - ((pair? e) - (call-with-values (lambda () (f (cdr e) w)) - (lambda (xr* y-pat r) - (if r - (if (null? y-pat) - (let ((xr (match (car e) x-pat w '() mod))) - (if xr - (values (cons xr xr*) y-pat r) - (values #f #f #f))) - (values - '() - (cdr y-pat) - (match (car e) (car y-pat) w r mod))) - (values #f #f #f))))) - ((syntax? e) - (f (syntax-expression e) - (join-wraps w (syntax-wrap e)))) - (else - (values '() y-pat (match e z-pat w r mod))))))) + ((pair? x) + (annotate (cons (unstrip (car x)) (unstrip (cdr x))))) + ((vector? x) + (let ((v (make-vector (vector-length x)))) + (annotate (list->vector (map unstrip (vector->list x)))))) + ((syntax? x) x) + (else (annotate x)))) + (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew + (cons 'hygiene (module-name (current-module)))))) + + (set! identifier? + (lambda (x) + (nonsymbol-id? x))) + + (set! datum->syntax + (lambda* (id datum #:key source) + (define (props->sourcev alist) + (and (pair? alist) + (vector (assq-ref alist 'filename) + (assq-ref alist 'line) + (assq-ref alist 'column)))) + (make-syntax datum + (if id + (syntax-wrap id) + empty-wrap) + (if id + (syntax-module id) + #f) + (cond + ((not source) + (props->sourcev (source-properties datum))) + ((and (list? source) (and-map pair? source)) + (props->sourcev source)) + ((and (vector? source) (= 3 (vector-length source))) + source) + (else (syntax-sourcev source)))))) + + (set! syntax->datum + ;; accepts any object, since syntax objects may consist partially + ;; or entirely of unwrapped, nonsymbolic data + (lambda (x) + (strip x))) + + (set! generate-temporaries + (lambda (ls) + (arg-check list? ls 'generate-temporaries) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (map (lambda (x) + (wrap (gen-var 't) top-wrap mod)) + ls)))) + + (set! free-identifier=? + (lambda (x y) + (arg-check nonsymbol-id? x 'free-identifier=?) + (arg-check nonsymbol-id? y 'free-identifier=?) + (free-id=? x y))) + + (set! bound-identifier=? + (lambda (x y) + (arg-check nonsymbol-id? x 'bound-identifier=?) + (arg-check nonsymbol-id? y 'bound-identifier=?) + (bound-id=? x y))) + + (set! syntax-violation + (lambda* (who message form #:optional subform) + (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) + who 'syntax-violation) + (arg-check string? message 'syntax-violation) + (throw 'syntax-error who message + (sourcev->alist + (or (source-annotation subform) + (source-annotation form))) + (strip form) + (strip subform)))) - (define match-each-any - (lambda (e w mod) + (let () + (define (%syntax-module id) + (arg-check nonsymbol-id? id 'syntax-module) + (let ((mod (syntax-module id))) + (and mod + (not (equal? mod '(primitive))) + (cdr mod)))) + + (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t)) + (arg-check nonsymbol-id? id 'syntax-local-binding) + (with-transformer-environment + (lambda (e r w s rib mod) + (define (strip-anti-mark w) + (let ((ms (wrap-marks w)) (s (wrap-subst w))) + (if (and (pair? ms) (eq? (car ms) the-anti-mark)) + ;; output is from original text + (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) + ;; output introduced by macro + (make-wrap ms (if rib (cons rib s) s))))) + (call-with-values (lambda () + (resolve-identifier + (syntax-expression id) + (strip-anti-mark (syntax-wrap id)) + r + (or (syntax-module id) mod) + resolve-syntax-parameters?)) + (lambda (type value mod) + (case type + ((lexical) (values 'lexical value)) + ((macro) (values 'macro value)) + ((syntax-parameter) (values 'syntax-parameter value)) + ((syntax) (values 'pattern-variable value)) + ((displaced-lexical) (values 'displaced-lexical #f)) + ((global) + (if (equal? mod '(primitive)) + (values 'primitive value) + (values 'global (cons value (cdr mod))))) + ((ellipsis) + (values 'ellipsis + (wrap-syntax value (anti-mark (syntax-wrap value)) + mod))) + (else (values 'other #f)))))))) + + (define (syntax-locally-bound-identifiers id) + (arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers) + (locally-bound-identifiers (syntax-wrap id) + (syntax-module id))) + + ;; Using define! instead of set! to avoid warnings at + ;; compile-time, after the variables are stolen away into (system + ;; syntax). See the end of boot-9.scm. + ;; + (define! '%syntax-module %syntax-module) + (define! 'syntax-local-binding syntax-local-binding) + (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers)) + + ;; $sc-dispatch expects an expression and a pattern. If the expression + ;; matches the pattern a list of the matching expressions for each + ;; "any" is returned. Otherwise, #f is returned. (This use of #f will + ;; not work on r4rs implementations that violate the ieee requirement + ;; that #f and () be distinct.) + + ;; The expression is matched with the pattern as follows: + + ;; pattern: matches: + ;; () empty list + ;; any anything + ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2) + ;; each-any (any*) + ;; #(free-id <key>) <key> with free-identifier=? + ;; #(each <pattern>) (<pattern>*) + ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) + ;; #(vector <pattern>) (list->vector <pattern>) + ;; #(atom <object>) <object> with "equal?" + + ;; Vector cops out to pair under assumption that vectors are rare. If + ;; not, should convert to: + ;; #(vector <pattern>*) #(<pattern>*) + + (let () + + (define match-each + (lambda (e p w mod) + (cond + ((pair? e) + (let ((first (match (car e) p w '() mod))) + (and first + (let ((rest (match-each (cdr e) p w mod))) + (and rest (cons first rest)))))) + ((null? e) '()) + ((syntax? e) + (match-each (syntax-expression e) + p + (join-wraps w (syntax-wrap e)) + (or (syntax-module e) mod))) + (else #f)))) + + (define match-each+ + (lambda (e x-pat y-pat z-pat w r mod) + (let f ((e e) (w w)) (cond ((pair? e) - (let ((l (match-each-any (cdr e) w mod))) - (and l (cons (wrap (car e) w mod) l)))) - ((null? e) '()) + (call-with-values (lambda () (f (cdr e) w)) + (lambda (xr* y-pat r) + (if r + (if (null? y-pat) + (let ((xr (match (car e) x-pat w '() mod))) + (if xr + (values (cons xr xr*) y-pat r) + (values #f #f #f))) + (values + '() + (cdr y-pat) + (match (car e) (car y-pat) w r mod))) + (values #f #f #f))))) ((syntax? e) - (match-each-any (syntax-expression e) - (join-wraps w (syntax-wrap e)) - mod)) - (else #f)))) - - (define match-empty - (lambda (p r) - (cond - ((null? p) r) - ((eq? p '_) r) - ((eq? p 'any) (cons '() r)) - ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) - ((eq? p 'each-any) (cons '() r)) - (else - (case (vector-ref p 0) - ((each) (match-empty (vector-ref p 1) r)) - ((each+) (match-empty (vector-ref p 1) - (match-empty - (reverse (vector-ref p 2)) - (match-empty (vector-ref p 3) r)))) - ((free-id atom) r) - ((vector) (match-empty (vector-ref p 1) r))))))) - - (define combine - (lambda (r* r) - (if (null? (car r*)) - r - (cons (map car r*) (combine (map cdr r*) r))))) - - (define match* - (lambda (e p w r mod) - (cond - ((null? p) (and (null? e) r)) - ((pair? p) - (and (pair? e) (match (car e) (car p) w - (match (cdr e) (cdr p) w r mod) - mod))) - ((eq? p 'each-any) - (let ((l (match-each-any e w mod))) (and l (cons l r)))) + (f (syntax-expression e) + (join-wraps w (syntax-wrap e)))) (else - (case (vector-ref p 0) - ((each) - (if (null? e) - (match-empty (vector-ref p 1) r) - (let ((l (match-each e (vector-ref p 1) w mod))) - (and l - (let collect ((l l)) - (if (null? (car l)) - r - (cons (map car l) (collect (map cdr l))))))))) - ((each+) - (call-with-values - (lambda () - (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod)) - (lambda (xr* y-pat r) - (and r - (null? y-pat) - (if (null? xr*) - (match-empty (vector-ref p 1) r) - (combine xr* r)))))) - ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) - ((atom) (and (equal? (vector-ref p 1) (strip e)) r)) - ((vector) - (and (vector? e) - (match (vector->list e) (vector-ref p 1) w r mod)))))))) - - (define match - (lambda (e p w r mod) - (cond - ((not r) #f) - ((eq? p '_) r) - ((eq? p 'any) (cons (wrap e w mod) r)) - ((syntax? e) - (match* - (syntax-expression e) - p - (join-wraps w (syntax-wrap e)) - r - (or (syntax-module e) mod))) - (else (match* e p w r mod))))) - - (set! $sc-dispatch - (lambda (e p) - (cond - ((eq? p 'any) (list e)) - ((eq? p '_) '()) - ((syntax? e) - (match* (syntax-expression e) - p (syntax-wrap e) '() (syntax-module e))) - (else (match* e p empty-wrap '() #f)))))))) + (values '() y-pat (match e z-pat w r mod))))))) + + (define match-each-any + (lambda (e w mod) + (cond + ((pair? e) + (let ((l (match-each-any (cdr e) w mod))) + (and l (cons (wrap (car e) w mod) l)))) + ((null? e) '()) + ((syntax? e) + (match-each-any (syntax-expression e) + (join-wraps w (syntax-wrap e)) + mod)) + (else #f)))) + + (define match-empty + (lambda (p r) + (cond + ((null? p) r) + ((eq? p '_) r) + ((eq? p 'any) (cons '() r)) + ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) + ((eq? p 'each-any) (cons '() r)) + (else + (case (vector-ref p 0) + ((each) (match-empty (vector-ref p 1) r)) + ((each+) (match-empty (vector-ref p 1) + (match-empty + (reverse (vector-ref p 2)) + (match-empty (vector-ref p 3) r)))) + ((free-id atom) r) + ((vector) (match-empty (vector-ref p 1) r))))))) + + (define combine + (lambda (r* r) + (if (null? (car r*)) + r + (cons (map car r*) (combine (map cdr r*) r))))) + + (define match* + (lambda (e p w r mod) + (cond + ((null? p) (and (null? e) r)) + ((pair? p) + (and (pair? e) (match (car e) (car p) w + (match (cdr e) (cdr p) w r mod) + mod))) + ((eq? p 'each-any) + (let ((l (match-each-any e w mod))) (and l (cons l r)))) + (else + (case (vector-ref p 0) + ((each) + (if (null? e) + (match-empty (vector-ref p 1) r) + (let ((l (match-each e (vector-ref p 1) w mod))) + (and l + (let collect ((l l)) + (if (null? (car l)) + r + (cons (map car l) (collect (map cdr l))))))))) + ((each+) + (call-with-values + (lambda () + (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod)) + (lambda (xr* y-pat r) + (and r + (null? y-pat) + (if (null? xr*) + (match-empty (vector-ref p 1) r) + (combine xr* r)))))) + ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) + ((atom) (and (equal? (vector-ref p 1) (strip e)) r)) + ((vector) + (and (vector? e) + (match (vector->list e) (vector-ref p 1) w r mod)))))))) + + (define match + (lambda (e p w r mod) + (cond + ((not r) #f) + ((eq? p '_) r) + ((eq? p 'any) (cons (wrap e w mod) r)) + ((syntax? e) + (match* + (syntax-expression e) + p + (join-wraps w (syntax-wrap e)) + r + (or (syntax-module e) mod))) + (else (match* e p w r mod))))) + + (set! $sc-dispatch + (lambda (e p) + (cond + ((eq? p 'any) (list e)) + ((eq? p '_) '()) + ((syntax? e) + (match* (syntax-expression e) + p (syntax-wrap e) '() (syntax-module e))) + (else (match* e p empty-wrap '() #f))))))) (define-syntax with-syntax |