mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
3196 lines
132 KiB
Scheme
3196 lines
132 KiB
Scheme
;;;; -*-scheme-*-
|
||
;;;;
|
||
;;;; Copyright (C) 1997-1998,2000-2003,2005-2006,2008-2013,2015-2022,2024
|
||
;;;; Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This library is free software: you can redistribute it and/or modify
|
||
;;;; it under the terms of the GNU Lesser General Public License as
|
||
;;;; published by the Free Software Foundation, either version 3 of the
|
||
;;;; License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library is distributed in the hope that it will be useful, but
|
||
;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this program. If not, see
|
||
;;;; <http://www.gnu.org/licenses/>.
|
||
|
||
|
||
;;; Originally extracted from Chez Scheme Version 5.9f
|
||
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
|
||
|
||
;;; Copyright (c) 1992-1997 Cadence Research Systems
|
||
;;; Permission to copy this software, in whole or in part, to use this
|
||
;;; software for any lawful purpose, and to redistribute this software
|
||
;;; is granted subject to the restriction that all copies made of this
|
||
;;; software must include this copyright notice in full. This software
|
||
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
|
||
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
|
||
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
|
||
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
|
||
;;; NATURE WHATSOEVER.
|
||
|
||
;;; This code is based on "Syntax Abstraction in Scheme"
|
||
;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
|
||
;;; Lisp and Symbolic Computation 5:4, 295-326, 1992.
|
||
;;; <http://www.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf>
|
||
|
||
|
||
;;; This file defines Guile's syntax expander and a set of associated
|
||
;;; syntactic forms and procedures. For more documentation, see The
|
||
;;; Scheme Programming Language, Fourth Edition (R. Kent Dybvig, MIT
|
||
;;; Press, 2009), or the R6RS.
|
||
|
||
;;; This file is shipped along with an expanded version of itself,
|
||
;;; psyntax-pp.scm, which is loaded when psyntax.scm has not yet been
|
||
;;; compiled. In this way, psyntax bootstraps off of an expanded
|
||
;;; version of itself.
|
||
|
||
|
||
;;; Implementation notes:
|
||
|
||
;;; Objects with no standard print syntax, including objects containing
|
||
;;; cycles and syntax object, are allowed in quoted data as long as they
|
||
;;; are contained within a syntax form or produced by datum->syntax.
|
||
;;; Such objects are never copied.
|
||
|
||
;;; All identifiers that don't have macro definitions and are not bound
|
||
;;; lexically are assumed to be global variables.
|
||
|
||
;;; Top-level definitions of macro-introduced identifiers are allowed.
|
||
|
||
;;; When changing syntax representations, it is necessary to support
|
||
;;; both old and new syntax representations in id-var-name. It
|
||
;;; should be sufficient to recognize old representations and treat
|
||
;;; them as not lexically bound.
|
||
|
||
|
||
(eval-when (compile)
|
||
(set-current-module (resolve-module '(guile))))
|
||
|
||
(let ((syntax? (module-ref (current-module) 'syntax?))
|
||
(make-syntax (module-ref (current-module) 'make-syntax))
|
||
(syntax-expression (module-ref (current-module) 'syntax-expression))
|
||
(syntax-wrap (module-ref (current-module) 'syntax-wrap))
|
||
(syntax-module (module-ref (current-module) 'syntax-module))
|
||
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
|
||
|
||
(define-syntax define-expansion-constructors
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((_)
|
||
(let lp ((n 0) (out '()))
|
||
(if (< n (vector-length %expanded-vtables))
|
||
(lp (1+ n)
|
||
(let* ((vtable (vector-ref %expanded-vtables n))
|
||
(stem (struct-ref vtable (+ vtable-offset-user 0)))
|
||
(fields (struct-ref vtable (+ vtable-offset-user 2)))
|
||
(sfields (map (lambda (f) (datum->syntax x f)) fields))
|
||
(ctor (datum->syntax x (symbol-append 'make- stem))))
|
||
(cons #`(define (#,ctor #,@sfields)
|
||
(make-struct/simple
|
||
(vector-ref %expanded-vtables #,n)
|
||
#,@sfields))
|
||
out)))
|
||
#`(begin #,@(reverse out))))))))
|
||
|
||
(define-syntax define-expansion-accessors
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((_ stem field ...)
|
||
(let ((stem (syntax->datum #'stem))
|
||
(fields (map syntax->datum #'(field ...))))
|
||
(let lp ((n 0))
|
||
(let ((vtable (vector-ref %expanded-vtables n)))
|
||
(if (eq? (struct-ref vtable (+ vtable-offset-user 0)) stem)
|
||
(let ((pred (datum->syntax x (symbol-append stem '?)))
|
||
(all-fields (struct-ref vtable (+ vtable-offset-user 2))))
|
||
#`(begin
|
||
(define (#,pred x)
|
||
(and (struct? x)
|
||
(eq? (struct-vtable x)
|
||
(vector-ref %expanded-vtables #,n))))
|
||
#,@(map
|
||
(lambda (f)
|
||
(define get
|
||
(datum->syntax x (symbol-append stem '- f)))
|
||
(define idx
|
||
(list-index all-fields f))
|
||
#`(define (#,get x)
|
||
(struct-ref x #,idx)))
|
||
fields)))
|
||
(lp (1+ n))))))))))
|
||
|
||
(define-expansion-constructors)
|
||
(define-expansion-accessors lambda src meta body)
|
||
|
||
;; A simple pattern matcher based on Oleg Kiselyov's pmatch.
|
||
(define-syntax-rule (simple-match e cs ...)
|
||
(let ((v e)) (simple-match-1 v cs ...)))
|
||
|
||
(define-syntax simple-match-1
|
||
(syntax-rules ()
|
||
((_ v) (error "value failed to match" v))
|
||
((_ v (pat e0 e ...) cs ...)
|
||
(let ((fk (lambda () (simple-match-1 v cs ...))))
|
||
(simple-match-pat v pat (let () e0 e ...) (fk))))))
|
||
|
||
(define-syntax simple-match-patv
|
||
(syntax-rules ()
|
||
((_ v idx () kt kf) kt)
|
||
((_ v idx (x . y) kt kf)
|
||
(simple-match-pat (vector-ref v idx) x
|
||
(simple-match-patv v (1+ idx) y kt kf)
|
||
kf))))
|
||
|
||
(define-syntax simple-match-pat
|
||
(syntax-rules (_ quote unquote ? and or not)
|
||
((_ v _ kt kf) kt)
|
||
((_ v () kt kf) (if (null? v) kt kf))
|
||
((_ v #t kt kf) (if (eq? v #t) kt kf))
|
||
((_ v #f kt kf) (if (eq? v #f) kt kf))
|
||
((_ v (and) kt kf) kt)
|
||
((_ v (and x . y) kt kf)
|
||
(simple-match-pat v x (simple-match-pat v (and . y) kt kf) kf))
|
||
((_ v (or) kt kf) kf)
|
||
((_ v (or x . y) kt kf)
|
||
(let ((tk (lambda () kt)))
|
||
(simple-match-pat v x (tk) (simple-match-pat v (or . y) (tk) kf))))
|
||
((_ v (not pat) kt kf) (simple-match-pat v pat kf kt))
|
||
((_ v (quote lit) kt kf)
|
||
(if (eq? v (quote lit)) kt kf))
|
||
((_ v (? proc) kt kf) (simple-match-pat v (? proc _) kt kf))
|
||
((_ v (? proc pat) kt kf)
|
||
(if (proc v) (simple-match-pat v pat kt kf) kf))
|
||
((_ v (x . y) kt kf)
|
||
(if (pair? v)
|
||
(let ((vx (car v)) (vy (cdr v)))
|
||
(simple-match-pat vx x (simple-match-pat vy y kt kf) kf))
|
||
kf))
|
||
((_ v #(x ...) kt kf)
|
||
(if (and (vector? v)
|
||
(eq? (vector-length v) (length '(x ...))))
|
||
(simple-match-patv v 0 (x ...) kt kf)
|
||
kf))
|
||
((_ v var kt kf) (let ((var v)) kt))))
|
||
|
||
(define-syntax-rule (match e cs ...) (simple-match e cs ...))
|
||
|
||
(define (top-level-eval x mod)
|
||
(primitive-eval x))
|
||
|
||
(define (local-eval x mod)
|
||
(primitive-eval x))
|
||
|
||
(define (global-extend type sym val)
|
||
(module-define! (current-module) sym
|
||
(make-syntax-transformer sym type val)))
|
||
|
||
(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 make-void)
|
||
(define build-call make-call)
|
||
(define build-conditional make-conditional)
|
||
(define build-lexical-reference make-lexical-ref)
|
||
(define (build-lexical-assignment src name var exp)
|
||
(make-lexical-set src name var (maybe-name-value name exp)))
|
||
|
||
(define (analyze-variable mod var modref-cont bare-cont)
|
||
(match mod
|
||
(#f (bare-cont #f var))
|
||
(('public . mod) (modref-cont mod var #t))
|
||
(((or 'private 'hygiene) . mod)
|
||
(if (equal? mod (module-name (current-module)))
|
||
(bare-cont mod var)
|
||
(modref-cont mod var #f)))
|
||
(('primitive . _)
|
||
(syntax-violation #f "primitive not in operator position" var))))
|
||
|
||
(define (build-global-reference src var mod)
|
||
(analyze-variable
|
||
mod var
|
||
(lambda (mod var public?)
|
||
(make-module-ref src mod var public?))
|
||
(lambda (mod var)
|
||
(make-toplevel-ref src mod var))))
|
||
|
||
(define (build-global-assignment src var exp mod)
|
||
(let ((exp (maybe-name-value var exp)))
|
||
(analyze-variable
|
||
mod var
|
||
(lambda (mod var public?)
|
||
(make-module-set src mod var public? exp))
|
||
(lambda (mod var)
|
||
(make-toplevel-set src mod var exp)))))
|
||
|
||
(define (build-global-definition src mod var exp)
|
||
(make-toplevel-define src (and mod (cdr mod)) var
|
||
(maybe-name-value var exp)))
|
||
|
||
(define (build-simple-lambda src req rest vars meta exp)
|
||
(make-lambda src meta
|
||
(make-lambda-case
|
||
;; src req opt rest kw inits vars body else
|
||
src req #f rest #f '() vars exp #f)))
|
||
|
||
(define build-case-lambda make-lambda)
|
||
(define build-lambda-case make-lambda-case)
|
||
(define build-primcall make-primcall)
|
||
(define build-primref make-primitive-ref)
|
||
(define build-data make-const)
|
||
|
||
(define (build-sequence src exps)
|
||
(match exps
|
||
((tail) tail)
|
||
((head . tail)
|
||
(make-seq src head (build-sequence #f tail)))))
|
||
|
||
(define (build-let src ids vars val-exps body-exp)
|
||
(match (map maybe-name-value ids val-exps)
|
||
(() body-exp)
|
||
(val-exps (make-let src ids vars val-exps body-exp))))
|
||
|
||
(define (build-named-let src ids vars val-exps body-exp)
|
||
(match vars
|
||
((f . vars)
|
||
(match ids
|
||
((f-name . 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 src f-name f)
|
||
(map maybe-name-value ids val-exps)))))))))
|
||
|
||
(define (build-letrec src in-order? ids vars val-exps body-exp)
|
||
(match (map maybe-name-value ids val-exps)
|
||
(() body-exp)
|
||
(val-exps (make-letrec src in-order? ids vars 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 no-source #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 x)
|
||
(if (syntax? x)
|
||
(syntax-sourcev x)
|
||
(datum-sourcev x)))
|
||
|
||
(define-syntax-rule (arg-check pred? e who)
|
||
(let ((x e))
|
||
(unless (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
|
||
;; its 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 (binding-type x) (car x))
|
||
(define (binding-value x) (cdr x))
|
||
(define null-env '())
|
||
|
||
(define (extend-env labels bindings r)
|
||
(match labels
|
||
(() r)
|
||
((label . labels)
|
||
(match bindings
|
||
((binding . bindings)
|
||
(extend-env labels bindings (acons label binding r)))))))
|
||
|
||
(define (extend-var-env labels vars r)
|
||
;; variant of extend-env that forms "lexical" binding
|
||
(match labels
|
||
(() r)
|
||
((label . labels)
|
||
(match vars
|
||
((var . vars)
|
||
(extend-var-env labels vars
|
||
(acons label (make-binding 'lexical var) 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 r)
|
||
(match r
|
||
(() '())
|
||
((a . r)
|
||
(match a
|
||
((k . ((or 'macro 'syntax-parameter 'ellipsis) . _))
|
||
(cons a (macros-only-env r)))
|
||
(_
|
||
(macros-only-env r))))))
|
||
|
||
;; 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? x)
|
||
(and (syntax? x)
|
||
(symbol? (syntax-expression x))))
|
||
|
||
(define (id? x)
|
||
(cond
|
||
((symbol? x) #t)
|
||
((syntax? x) (symbol? (syntax-expression x)))
|
||
(else #f)))
|
||
|
||
(define (id-sym-name x)
|
||
(if (syntax? x)
|
||
(syntax-expression x)
|
||
x))
|
||
|
||
(define (id-sym-name&marks 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 (make-wrap marks subst) (cons marks subst))
|
||
(define (wrap-marks wrap) (car wrap))
|
||
(define (wrap-subst wrap) (cdr wrap))
|
||
|
||
(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)
|
||
(match ls
|
||
(() '())
|
||
((_ . ls) (cons (gen-label) (gen-labels 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 empty-wrap '(()))
|
||
(define top-wrap '((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 the-anti-mark #f)
|
||
|
||
(define (anti-mark 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 (make-empty-ribcage)
|
||
(make-ribcage '() '() '()))
|
||
|
||
(define (extend-ribcage! ribcage id label)
|
||
;; must receive ids with complete wraps
|
||
(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 ids labels w)
|
||
(match ids
|
||
(() w)
|
||
((_ . _)
|
||
(make-wrap
|
||
(wrap-marks w)
|
||
(cons
|
||
(let* ((labelvec (list->vector labels))
|
||
(n (vector-length labelvec))
|
||
(symnamevec (make-vector n))
|
||
(marksvec (make-vector n)))
|
||
(let f ((ids ids) (i 0))
|
||
(match ids
|
||
(()
|
||
(make-ribcage symnamevec marksvec labelvec))
|
||
((id . ids)
|
||
(call-with-values
|
||
(lambda () (id-sym-name&marks id w))
|
||
(lambda (symname marks)
|
||
(vector-set! symnamevec i symname)
|
||
(vector-set! marksvec i marks)
|
||
(f ids (1+ i))))))))
|
||
(wrap-subst w))))))
|
||
|
||
(define (smart-append m1 m2)
|
||
(if (null? m2)
|
||
m1
|
||
(append m1 m2)))
|
||
|
||
(define (join-wraps 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 m1 m2)
|
||
(smart-append m1 m2))
|
||
|
||
(define (same-marks? 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 id w mod)
|
||
;; 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.
|
||
;;
|
||
(define (search sym subst marks)
|
||
(match subst
|
||
(() #f)
|
||
(('shift . subst)
|
||
(match marks
|
||
((_ . marks)
|
||
(search sym subst marks))))
|
||
((#('ribcage rsymnames rmarks rlabels) . subst)
|
||
(define (search-list-rib)
|
||
(let lp ((rsymnames rsymnames)
|
||
(rmarks rmarks)
|
||
(rlabels rlabels))
|
||
(match rsymnames
|
||
(() (search sym subst marks))
|
||
((rsym . rsymnames)
|
||
(match rmarks
|
||
((rmarks1 . rmarks)
|
||
(match rlabels
|
||
((label . rlabels)
|
||
(if (and (eq? sym rsym) (same-marks? marks rmarks1))
|
||
(match label
|
||
((mod* . label)
|
||
(if (equal? mod* mod)
|
||
label
|
||
(lp rsymnames rmarks rlabels)))
|
||
(_ label))
|
||
(lp rsymnames rmarks rlabels))))))))))
|
||
(define (search-vector-rib)
|
||
(let ((n (vector-length rsymnames)))
|
||
(let lp ((i 0))
|
||
(cond
|
||
((= i n) (search sym subst marks))
|
||
((and (eq? (vector-ref rsymnames i) sym)
|
||
(same-marks? marks (vector-ref rmarks i)))
|
||
(match (vector-ref rlabels i)
|
||
((mod* . label)
|
||
(if (equal? mod* mod)
|
||
label
|
||
(lp (1+ i))))
|
||
(label
|
||
label)))
|
||
(else (lp (1+ i)))))))
|
||
(if (vector? rsymnames)
|
||
(search-vector-rib)
|
||
(search-list-rib)))))
|
||
(cond
|
||
((symbol? id)
|
||
(or (search id (wrap-subst w) (wrap-marks w)) 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))))
|
||
(or (search id (wrap-subst w) marks)
|
||
(search id (wrap-subst w1) marks)
|
||
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 w mod)
|
||
(define (scan subst results)
|
||
(match subst
|
||
(() results)
|
||
(('shift . subst) (scan subst results))
|
||
((#('ribcage symnames marks labels) . subst*)
|
||
(define (scan-list-rib)
|
||
(let lp ((symnames symnames) (marks marks) (results results))
|
||
(match symnames
|
||
(() (scan subst* results))
|
||
((sym . symnames)
|
||
(match marks
|
||
((m . marks)
|
||
(lp symnames marks
|
||
(cons (wrap sym (anti-mark (make-wrap m subst)) mod)
|
||
results))))))))
|
||
(define (scan-vector-rib)
|
||
(let ((n (vector-length symnames)))
|
||
(let lp ((i 0) (results results))
|
||
(if (= i n)
|
||
(scan subst* results)
|
||
(lp (1+ i)
|
||
(let ((sym (vector-ref symnames i))
|
||
(m (vector-ref marks i)))
|
||
(cons (wrap sym (anti-mark (make-wrap m subst)) mod)
|
||
results)))))))
|
||
(if (vector? symnames)
|
||
(scan-vector-rib)
|
||
(scan-list-rib)))))
|
||
(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)))
|
||
(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
|
||
((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)))
|
||
(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=? 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))
|
||
(bj (id-module-binding j mj)))
|
||
(and (eq? bi bj)
|
||
(or bi (eq? ni nj))))))
|
||
(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=? 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? ids)
|
||
(and (let all-ids? ((ids ids))
|
||
(match ids
|
||
(() #t)
|
||
((id . ids)
|
||
(and (id? id) (all-ids? 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? ids)
|
||
(let distinct? ((ids ids))
|
||
(match ids
|
||
(() #t)
|
||
((id . ids)
|
||
(and (not (bound-id-member? id ids))
|
||
(distinct? ids))))))
|
||
|
||
(define (bound-id-member? x ids)
|
||
(match ids
|
||
(() #f)
|
||
((id . ids)
|
||
(or (bound-id=? x id)
|
||
(bound-id-member? x ids)))))
|
||
|
||
;; wrapping expressions and identifiers
|
||
|
||
(define (wrap 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 body r w s mod)
|
||
(build-sequence s
|
||
(let lp ((body body))
|
||
(match body
|
||
(() '())
|
||
((head . tail)
|
||
(let ((expr (expand head r w mod)))
|
||
(cons expr (lp tail))))))))
|
||
|
||
;; 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 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)))
|
||
(match labels
|
||
(() #f)
|
||
(((_ . wrapped) . labels)
|
||
(or (eq? (syntax-expression wrapped) var)
|
||
(lp 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))
|
||
(match body
|
||
(() '())
|
||
((head . tail)
|
||
(let ((thunks (parse1 head r w s m esew mod)))
|
||
(append thunks (lp tail)))))))
|
||
(define (parse1 x r w s m esew mod)
|
||
(define (current-module-for-expansion mod)
|
||
(match mod
|
||
(('hygiene . _)
|
||
;; 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.
|
||
(cons 'hygiene (module-name (current-module))))
|
||
(_ 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.
|
||
(when (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
|
||
(when (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
|
||
(when (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)))))))))
|
||
(match (let lp ((thunks (parse body r w s m esew mod)))
|
||
(match thunks
|
||
(() '())
|
||
((thunk . thunks) (cons (thunk) (lp thunks)))))
|
||
(() (build-void s))
|
||
(exps (build-sequence s exps)))))
|
||
|
||
(define (expand-install-global 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 e when-list)
|
||
(let ((result (strip when-list)))
|
||
(let lp ((l result))
|
||
(match l
|
||
(() result)
|
||
((x . l)
|
||
(match x
|
||
((or 'compile 'load 'eval 'expand) (lp l))
|
||
(_ (syntax-violation 'eval-when "invalid situation" e x))))))))
|
||
|
||
;; 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 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)
|
||
(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 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 type value form e r w s mod)
|
||
(case type
|
||
((lexical)
|
||
(build-lexical-reference 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 (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 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 p e r w s rib mod)
|
||
(define (decorate-source x)
|
||
(source-wrap x empty-wrap s #f))
|
||
(define (map* f x)
|
||
(match x
|
||
(() '())
|
||
((x . x*) (cons (f x) (map* f x*)))
|
||
(x (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 body outer-form r w mod)
|
||
;; 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
|
||
(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 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 expanded mod)
|
||
(let ((p (local-eval expanded mod)))
|
||
(unless (procedure? p)
|
||
(syntax-violation #f "nonprocedure transformer" p))
|
||
p))
|
||
|
||
(define (expand-void)
|
||
(build-void no-source))
|
||
|
||
(define (ellipsis? 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 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 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 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 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 (cons v vars) r* w*
|
||
(if (pair? kw) (car kw) #f)
|
||
'() 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 id)
|
||
(let ((id (if (syntax? id) (syntax-expression id) id)))
|
||
(gen-lexical id)))
|
||
|
||
;; appears to return a reversed list
|
||
(define (lambda-var-list 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
|
||
|
||
(define (expand-syntax-parameterize 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)))))
|
||
|
||
(define (expand-quote 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)))))
|
||
|
||
(define (expand-quote-syntax 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))))
|
||
|
||
(define expand-syntax
|
||
(let ()
|
||
(define (gen-syntax 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 ()
|
||
(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)
|
||
(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 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 e map-env)
|
||
`(apply (primitive append) ,(gen-map e map-env)))
|
||
|
||
(define (gen-map 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 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 x y)
|
||
(if (equal? y '(quote ()))
|
||
x
|
||
`(append ,x ,y)))
|
||
|
||
(define (gen-vector x)
|
||
(cond
|
||
((eq? (car x) 'list) `(vector ,@(cdr x)))
|
||
((eq? (car x) 'quote) `(quote #(,@(cadr x))))
|
||
(else `(list->vector ,x))))
|
||
|
||
|
||
(define (regen x)
|
||
(case (car x)
|
||
((ref) (build-lexical-reference 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)))))))
|
||
|
||
(define (expand-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))))
|
||
|
||
(define (expand-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))))
|
||
|
||
(define (expand-case-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))))
|
||
|
||
(define (expand-case-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))))
|
||
|
||
(define (expand-with-ellipsis 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)))))
|
||
|
||
(define expand-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)))))))
|
||
|
||
(define (expand-letrec 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)))))
|
||
|
||
(define (expand-letrec* 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)))))
|
||
|
||
(define (expand-set! 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)))))
|
||
|
||
(define (expand-public-ref 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 ...))))))
|
||
|
||
(define (expand-private-ref e r w mod)
|
||
(define (remodulate 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)))))
|
||
|
||
(define (expand-if 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)))))
|
||
|
||
(define expand-syntax-case
|
||
(let ()
|
||
(define (convert-pattern pattern keys ellipsis?)
|
||
;; accepts pattern & keys
|
||
;; returns $sc-dispatch pattern & ids
|
||
(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 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 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 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 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 no-source 'tmp x)
|
||
#'(key ...) #'(m ...)
|
||
r
|
||
mod))
|
||
(list (expand #'val r empty-wrap mod))))
|
||
(syntax-violation 'syntax-case "invalid literals list" e))))))))
|
||
|
||
(global-extend 'local-syntax 'letrec-syntax #t)
|
||
(global-extend 'local-syntax 'let-syntax #f)
|
||
(global-extend 'core 'syntax-parameterize expand-syntax-parameterize)
|
||
(global-extend 'core 'quote expand-quote)
|
||
(global-extend 'core 'quote-syntax expand-quote-syntax)
|
||
(global-extend 'core 'syntax expand-syntax)
|
||
(global-extend 'core 'lambda expand-lambda)
|
||
(global-extend 'core 'lambda* expand-lambda*)
|
||
(global-extend 'core 'case-lambda expand-case-lambda)
|
||
(global-extend 'core 'case-lambda* expand-case-lambda*)
|
||
(global-extend 'core 'with-ellipsis expand-with-ellipsis)
|
||
(global-extend 'core 'let expand-let)
|
||
(global-extend 'core 'letrec expand-letrec)
|
||
(global-extend 'core 'letrec* expand-letrec*)
|
||
(global-extend 'core 'set! expand-set!)
|
||
(global-extend 'module-ref '@ expand-public-ref)
|
||
(global-extend 'module-ref '@@ expand-private-ref)
|
||
(global-extend 'core 'if expand-if)
|
||
(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 expand-syntax-case)
|
||
|
||
(define-syntax define/override
|
||
(syntax-rules ()
|
||
((_ (id . args) . body) (define/override id (lambda args . body)))
|
||
((_ id exp) (set! id exp))))
|
||
(define-syntax define*/override
|
||
(syntax-rules ()
|
||
((_ (id . args) . body) (define/override id (lambda* args . body)))))
|
||
|
||
;; 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.
|
||
(define*/override (macroexpand 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)))))
|
||
|
||
(define/override (identifier? x)
|
||
(nonsymbol-id? x))
|
||
|
||
(define*/override (datum->syntax 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)))))
|
||
|
||
(define/override (syntax->datum x)
|
||
;; accepts any object, since syntax objects may consist partially
|
||
;; or entirely of unwrapped, nonsymbolic data
|
||
(strip x))
|
||
|
||
(define/override (generate-temporaries 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)))
|
||
|
||
(define/override (free-identifier=? x y)
|
||
(arg-check nonsymbol-id? x 'free-identifier=?)
|
||
(arg-check nonsymbol-id? y 'free-identifier=?)
|
||
(free-id=? x y))
|
||
|
||
(define/override (bound-identifier=? x y)
|
||
(arg-check nonsymbol-id? x 'bound-identifier=?)
|
||
(arg-check nonsymbol-id? y 'bound-identifier=?)
|
||
(bound-id=? x y))
|
||
|
||
(define*/override (syntax-violation 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))
|
||
|
||
(define/override ($sc-dispatch e p)
|
||
;; $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.
|
||
|
||
;; 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>*)
|
||
|
||
(define (match-each 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+ e x-pat y-pat z-pat w r mod)
|
||
(let f ((e e) (w w))
|
||
(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))))))
|
||
|
||
(define (match-each-any 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 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 r* r)
|
||
(if (null? (car r*))
|
||
r
|
||
(cons (map car r*) (combine (map cdr r*) r))))
|
||
|
||
(define (match* 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 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))))
|
||
|
||
(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
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((_ () e1 e2 ...)
|
||
#'(let () e1 e2 ...))
|
||
((_ ((out in)) e1 e2 ...)
|
||
#'(syntax-case in ()
|
||
(out (let () e1 e2 ...))))
|
||
((_ ((out in) ...) e1 e2 ...)
|
||
#'(syntax-case (list in ...) ()
|
||
((out ...) (let () e1 e2 ...)))))))
|
||
|
||
(define-syntax syntax-error
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
;; Extended internal syntax which provides the original form
|
||
;; as the first operand, for improved error reporting.
|
||
((_ (keyword . operands) message arg ...)
|
||
(string? (syntax->datum #'message))
|
||
(syntax-violation (syntax->datum #'keyword)
|
||
(string-join (cons (syntax->datum #'message)
|
||
(map (lambda (x)
|
||
(object->string
|
||
(syntax->datum x)))
|
||
#'(arg ...))))
|
||
(and (syntax->datum #'keyword)
|
||
#'(keyword . operands))))
|
||
;; Standard R7RS syntax
|
||
((_ message arg ...)
|
||
(string? (syntax->datum #'message))
|
||
#'(syntax-error (#f) message arg ...)))))
|
||
|
||
(define-syntax syntax-rules
|
||
(lambda (xx)
|
||
(define (expand-clause clause)
|
||
;; Convert a 'syntax-rules' clause into a 'syntax-case' clause.
|
||
(syntax-case clause (syntax-error)
|
||
;; If the template is a 'syntax-error' form, use the extended
|
||
;; internal syntax, which adds the original form as the first
|
||
;; operand for improved error reporting.
|
||
(((keyword . pattern) (syntax-error message arg ...))
|
||
(string? (syntax->datum #'message))
|
||
#'((dummy . pattern) #'(syntax-error (dummy . pattern) message arg ...)))
|
||
;; Normal case
|
||
(((keyword . pattern) template)
|
||
#'((dummy . pattern) #'template))))
|
||
(define (expand-syntax-rules dots keys docstrings clauses)
|
||
(with-syntax
|
||
(((k ...) keys)
|
||
((docstring ...) docstrings)
|
||
((((keyword . pattern) template) ...) clauses)
|
||
((clause ...) (map expand-clause clauses)))
|
||
(with-syntax
|
||
((form #'(lambda (x)
|
||
docstring ... ; optional docstring
|
||
#((macro-type . syntax-rules)
|
||
(patterns pattern ...)) ; embed patterns as procedure metadata
|
||
(syntax-case x (k ...)
|
||
clause ...))))
|
||
(if dots
|
||
(with-syntax ((dots dots))
|
||
#'(with-ellipsis dots form))
|
||
#'form))))
|
||
(syntax-case xx ()
|
||
((_ (k ...) ((keyword . pattern) template) ...)
|
||
(expand-syntax-rules #f #'(k ...) #'() #'(((keyword . pattern) template) ...)))
|
||
((_ (k ...) docstring ((keyword . pattern) template) ...)
|
||
(string? (syntax->datum #'docstring))
|
||
(expand-syntax-rules #f #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...)))
|
||
((_ dots (k ...) ((keyword . pattern) template) ...)
|
||
(identifier? #'dots)
|
||
(expand-syntax-rules #'dots #'(k ...) #'() #'(((keyword . pattern) template) ...)))
|
||
((_ dots (k ...) docstring ((keyword . pattern) template) ...)
|
||
(and (identifier? #'dots) (string? (syntax->datum #'docstring)))
|
||
(expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))))))
|
||
|
||
(define-syntax define-syntax-rule
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((_ (name . pattern) template)
|
||
#'(define-syntax name
|
||
(syntax-rules ()
|
||
((_ . pattern) template))))
|
||
((_ (name . pattern) docstring template)
|
||
(string? (syntax->datum #'docstring))
|
||
#'(define-syntax name
|
||
(syntax-rules ()
|
||
docstring
|
||
((_ . pattern) template)))))))
|
||
|
||
(define-syntax let*
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((let* ((x v) ...) e1 e2 ...)
|
||
(and-map identifier? #'(x ...))
|
||
(let f ((bindings #'((x v) ...)))
|
||
(if (null? bindings)
|
||
#'(let () e1 e2 ...)
|
||
(with-syntax ((body (f (cdr bindings)))
|
||
(binding (car bindings)))
|
||
#'(let (binding) body))))))))
|
||
|
||
(define-syntax quasiquote
|
||
(let ()
|
||
(define (quasi p lev)
|
||
(syntax-case p (unquote quasiquote)
|
||
((unquote p)
|
||
(if (= lev 0)
|
||
#'("value" p)
|
||
(quasicons #'("quote" unquote) (quasi #'(p) (- lev 1)))))
|
||
((quasiquote p) (quasicons #'("quote" quasiquote) (quasi #'(p) (+ lev 1))))
|
||
((p . q)
|
||
(syntax-case #'p (unquote unquote-splicing)
|
||
((unquote p ...)
|
||
(if (= lev 0)
|
||
(quasilist* #'(("value" p) ...) (quasi #'q lev))
|
||
(quasicons
|
||
(quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
|
||
(quasi #'q lev))))
|
||
((unquote-splicing p ...)
|
||
(if (= lev 0)
|
||
(quasiappend #'(("value" p) ...) (quasi #'q lev))
|
||
(quasicons
|
||
(quasicons #'("quote" unquote-splicing) (quasi #'(p ...) (- lev 1)))
|
||
(quasi #'q lev))))
|
||
(_ (quasicons (quasi #'p lev) (quasi #'q lev)))))
|
||
(#(x ...) (quasivector (vquasi #'(x ...) lev)))
|
||
(p #'("quote" p))))
|
||
(define (vquasi p lev)
|
||
(syntax-case p ()
|
||
((p . q)
|
||
(syntax-case #'p (unquote unquote-splicing)
|
||
((unquote p ...)
|
||
(if (= lev 0)
|
||
(quasilist* #'(("value" p) ...) (vquasi #'q lev))
|
||
(quasicons
|
||
(quasicons #'("quote" unquote) (quasi #'(p ...) (- lev 1)))
|
||
(vquasi #'q lev))))
|
||
((unquote-splicing p ...)
|
||
(if (= lev 0)
|
||
(quasiappend #'(("value" p) ...) (vquasi #'q lev))
|
||
(quasicons
|
||
(quasicons
|
||
#'("quote" unquote-splicing)
|
||
(quasi #'(p ...) (- lev 1)))
|
||
(vquasi #'q lev))))
|
||
(_ (quasicons (quasi #'p lev) (vquasi #'q lev)))))
|
||
(() #'("quote" ()))))
|
||
(define (quasicons x y)
|
||
(with-syntax ((x x) (y y))
|
||
(syntax-case #'y ()
|
||
(("quote" dy)
|
||
(syntax-case #'x ()
|
||
(("quote" dx) #'("quote" (dx . dy)))
|
||
(_ (if (null? #'dy) #'("list" x) #'("list*" x y)))))
|
||
(("list" . stuff) #'("list" x . stuff))
|
||
(("list*" . stuff) #'("list*" x . stuff))
|
||
(_ #'("list*" x y)))))
|
||
(define (quasiappend x y)
|
||
(syntax-case y ()
|
||
(("quote" ())
|
||
(cond
|
||
((null? x) #'("quote" ()))
|
||
((null? (cdr x)) (car x))
|
||
(else (with-syntax (((p ...) x)) #'("append" p ...)))))
|
||
(_
|
||
(cond
|
||
((null? x) y)
|
||
(else (with-syntax (((p ...) x) (y y)) #'("append" p ... y)))))))
|
||
(define (quasilist* x y)
|
||
(let f ((x x))
|
||
(if (null? x)
|
||
y
|
||
(quasicons (car x) (f (cdr x))))))
|
||
(define (quasivector x)
|
||
(syntax-case x ()
|
||
(("quote" (x ...)) #'("quote" #(x ...)))
|
||
(_
|
||
(let f ((y x) (k (lambda (ls) #`("vector" #,@ls))))
|
||
(syntax-case y ()
|
||
(("quote" (y ...)) (k #'(("quote" y) ...)))
|
||
(("list" y ...) (k #'(y ...)))
|
||
(("list*" y ... z) (f #'z (lambda (ls) (k (append #'(y ...) ls)))))
|
||
(else #`("list->vector" #,x)))))))
|
||
(define (emit x)
|
||
(syntax-case x ()
|
||
(("quote" x) #''x)
|
||
(("list" x ...) #`(list #,@(map emit #'(x ...))))
|
||
;; could emit list* for 3+ arguments if implementation supports
|
||
;; list*
|
||
(("list*" x ... y)
|
||
(let f ((x* #'(x ...)))
|
||
(if (null? x*)
|
||
(emit #'y)
|
||
#`(cons #,(emit (car x*)) #,(f (cdr x*))))))
|
||
(("append" x ...) #`(append #,@(map emit #'(x ...))))
|
||
(("vector" x ...) #`(vector #,@(map emit #'(x ...))))
|
||
(("list->vector" x) #`(list->vector #,(emit #'x)))
|
||
(("value" x) #'x)))
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
;; convert to intermediate language, combining introduced (but
|
||
;; not unquoted source) quote expressions where possible and
|
||
;; choosing optimal construction code otherwise, then emit
|
||
;; Scheme code corresponding to the intermediate language forms.
|
||
((_ e) (emit (quasi #'e 0)))))))
|
||
|
||
(define call-with-include-port
|
||
(let ((syntax-dirname (lambda (stx)
|
||
(define src (syntax-source stx))
|
||
(define filename (and src (assq-ref src 'filename)))
|
||
(and (string? filename)
|
||
(dirname filename)))))
|
||
(lambda* (filename proc #:key (dirname (syntax-dirname filename)))
|
||
"Like @code{call-with-input-file}, except relative paths are
|
||
searched relative to the @var{dirname} instead of the current working
|
||
directory. Also, @var{filename} can be a syntax object; in that case,
|
||
and if @var{dirname} is not specified, the @code{syntax-source} of
|
||
@var{filename} is used to obtain a base directory for relative file
|
||
names."
|
||
(let* ((filename (syntax->datum filename))
|
||
(p (open-input-file
|
||
(cond ((absolute-file-name? filename)
|
||
filename)
|
||
(dirname
|
||
(in-vicinity dirname filename))
|
||
(else
|
||
(error
|
||
"attempt to include relative file name but could not determine base dir")))))
|
||
(enc (file-encoding p)))
|
||
|
||
;; Choose the input encoding deterministically.
|
||
(set-port-encoding! p (or enc "UTF-8"))
|
||
|
||
(call-with-values (lambda () (proc p))
|
||
(lambda results
|
||
(close-port p)
|
||
(apply values results)))))))
|
||
|
||
(define-syntax include
|
||
(lambda (stx)
|
||
(syntax-case stx ()
|
||
((_ filename)
|
||
(call-with-include-port
|
||
#'filename
|
||
(lambda (p)
|
||
;; In Guile, (cons #'a #'b) is the same as #'(a . b).
|
||
(cons #'begin
|
||
(let lp ()
|
||
(let ((x (read-syntax p)))
|
||
(if (eof-object? x)
|
||
#'()
|
||
(cons (datum->syntax #'filename x) (lp))))))))))))
|
||
|
||
(define-syntax include-from-path
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((k filename)
|
||
(let ((fn (syntax->datum #'filename)))
|
||
(with-syntax ((fn (datum->syntax
|
||
#'filename
|
||
(canonicalize-path
|
||
(or (%search-load-path fn)
|
||
(syntax-violation 'include-from-path
|
||
"file not found in path"
|
||
x #'filename))))))
|
||
#'(include fn)))))))
|
||
|
||
(define-syntax unquote
|
||
(lambda (x)
|
||
(syntax-violation 'unquote
|
||
"expression not valid outside of quasiquote"
|
||
x)))
|
||
|
||
(define-syntax unquote-splicing
|
||
(lambda (x)
|
||
(syntax-violation 'unquote-splicing
|
||
"expression not valid outside of quasiquote"
|
||
x)))
|
||
|
||
(define (make-variable-transformer proc)
|
||
(if (procedure? proc)
|
||
(let ((trans (lambda (x)
|
||
#((macro-type . variable-transformer))
|
||
(proc x))))
|
||
(set-procedure-property! trans 'variable-transformer #t)
|
||
trans)
|
||
(error "variable transformer not a procedure" proc)))
|
||
|
||
(define-syntax identifier-syntax
|
||
(lambda (xx)
|
||
(syntax-case xx (set!)
|
||
((_ e)
|
||
#'(lambda (x)
|
||
#((macro-type . identifier-syntax))
|
||
(syntax-case x ()
|
||
(id
|
||
(identifier? #'id)
|
||
#'e)
|
||
((_ x (... ...))
|
||
#'(e x (... ...))))))
|
||
((_ (id exp1) ((set! var val) exp2))
|
||
(and (identifier? #'id) (identifier? #'var))
|
||
#'(make-variable-transformer
|
||
(lambda (x)
|
||
#((macro-type . variable-transformer))
|
||
(syntax-case x (set!)
|
||
((set! var val) #'exp2)
|
||
((id x (... ...)) #'(exp1 x (... ...)))
|
||
(id (identifier? #'id) #'exp1))))))))
|
||
|
||
(define-syntax define*
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((_ (id . args) b0 b1 ...)
|
||
#'(define id (lambda* args b0 b1 ...)))
|
||
((_ id val) (identifier? #'id)
|
||
#'(define id val)))))
|