[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 08/12: psyntax: Remove a useless level of let
From: |
Andy Wingo |
Subject: |
[Guile-commits] 08/12: psyntax: Remove a useless level of let |
Date: |
Fri, 15 Nov 2024 10:25:32 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit 4f05d1709b8dbe5f457b220dd2509c5a187f5416
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Nov 15 13:57:57 2024 +0100
psyntax: Remove a useless level of let
* module/ice-9/psyntax.scm: Remove let around the body.
---
module/ice-9/psyntax.scm | 5557 +++++++++++++++++++++++-----------------------
1 file 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
- [Guile-commits] branch main updated (bb7154fb8 -> 2daea4020), Andy Wingo, 2024/11/15
- [Guile-commits] 05/12: psyntax: Clean up use of fx+, etc, Andy Wingo, 2024/11/15
- [Guile-commits] 06/12: psyntax: Functional annotation of function names, Andy Wingo, 2024/11/15
- [Guile-commits] 10/12: psyntax: Add simple pattern matcher, Andy Wingo, 2024/11/15
- [Guile-commits] 04/12: psyntax: Rename top-level-eval, local-eval, Andy Wingo, 2024/11/15
- [Guile-commits] 07/12: psyntax: Inline the single use of define-structure, Andy Wingo, 2024/11/15
- [Guile-commits] 08/12: psyntax: Remove a useless level of let,
Andy Wingo <=
- [Guile-commits] 12/12: psyntax: Use new `match' instead of cdadring, Andy Wingo, 2024/11/15
- [Guile-commits] 11/12: psyntax: Use new `match' instead of cdadring, Andy Wingo, 2024/11/15
- [Guile-commits] 09/12: psyntax: Avoid lambda in procedure definitions, Andy Wingo, 2024/11/15
- [Guile-commits] 01/12: psyntax: Clean up lexical gensym creation, Andy Wingo, 2024/11/15
- [Guile-commits] 03/12: psyntax: Use vectors instead of gensyms for labels, marks, Andy Wingo, 2024/11/15
- [Guile-commits] 02/12: psyntax: Remove useless gen-label invocations, Andy Wingo, 2024/11/15