diff options
author | Andy Wingo <wingo@pobox.com> | 2009-11-14 16:53:36 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-11-14 17:06:40 +0100 |
commit | c3ae0ed441a9ed5ce80da73456e4ea163f57c4b9 (patch) | |
tree | 5fe1e24b3c744efd20ebb1e19b7f6b5a27676235 | |
parent | ee2a69f565032c6699ce6291e48b8624b2da16ba (diff) | |
download | guile-c3ae0ed441a9ed5ce80da73456e4ea163f57c4b9.tar.gz |
psyntax.scm uses #' shorthand for (syntax ...)
* module/ice-9/psyntax.scm: Convert to use #'.
-rw-r--r-- | module/ice-9/psyntax.scm | 4229 |
1 files changed, 2114 insertions, 2115 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index b1c09f86c..5d3291388 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -239,393 +239,393 @@ args)))))) (syntax-case x () ((_ (name id1 ...)) - (and-map identifier? (syntax (name id1 ...))) + (and-map identifier? #'(name id1 ...)) (with-syntax - ((constructor (construct-name (syntax name) "make-" (syntax name))) - (predicate (construct-name (syntax name) (syntax name) "?")) - ((access ...) - (map (lambda (x) (construct-name x (syntax name) "-" x)) - (syntax (id1 ...)))) - ((assign ...) - (map (lambda (x) - (construct-name x "set-" (syntax name) "-" x "!")) - (syntax (id1 ...)))) - (structure-length - (+ (length (syntax (id1 ...))) 1)) - ((index ...) - (let f ((i 1) (ids (syntax (id1 ...)))) - (if (null? ids) - '() - (cons i (f (+ i 1) (cdr ids))))))) - (syntax (begin - (define constructor - (lambda (id1 ...) - (vector 'name id1 ... ))) - (define predicate - (lambda (x) - (and (vector? x) - (= (vector-length x) structure-length) - (eq? (vector-ref x 0) 'name)))) - (define access - (lambda (x) - (vector-ref x index))) - ... - (define assign - (lambda (x update) - (vector-set! x index update))) - ...))))))) + ((constructor (construct-name #'name "make-" #'name)) + (predicate (construct-name #'name #'name "?")) + ((access ...) + (map (lambda (x) (construct-name x #'name "-" x)) + #'(id1 ...))) + ((assign ...) + (map (lambda (x) + (construct-name x "set-" #'name "-" x "!")) + #'(id1 ...))) + (structure-length + (+ (length #'(id1 ...)) 1)) + ((index ...) + (let f ((i 1) (ids #'(id1 ...))) + (if (null? ids) + '() + (cons i (f (+ i 1) (cdr ids))))))) + #'(begin + (define constructor + (lambda (id1 ...) + (vector 'name id1 ... ))) + (define predicate + (lambda (x) + (and (vector? x) + (= (vector-length x) structure-length) + (eq? (vector-ref x 0) 'name)))) + (define access + (lambda (x) + (vector-ref x index))) + ... + (define assign + (lambda (x update) + (vector-set! x index update))) + ...)))))) (let () -(define noexpand "noexpand") -(define *mode* (make-fluid)) + (define noexpand "noexpand") + (define *mode* (make-fluid)) ;;; hooks to nonportable run-time helpers -(begin -(define fx+ +) -(define fx- -) -(define fx= =) -(define fx< <) - -(define top-level-eval-hook - (lambda (x mod) - (primitive-eval - `(,noexpand - ,(case (fluid-ref *mode*) - ((c) ((@ (language tree-il) tree-il->scheme) x)) - (else x)))))) - -(define local-eval-hook - (lambda (x mod) - (primitive-eval - `(,noexpand - ,(case (fluid-ref *mode*) - ((c) ((@ (language tree-il) tree-il->scheme) x)) - (else x)))))) - -(define-syntax gensym-hook - (syntax-rules () - ((_) (gensym)))) - -(define put-global-definition-hook - (lambda (symbol type val) - (let ((existing (let ((v (module-variable (current-module) symbol))) - (and v (variable-bound? v) - (let ((val (variable-ref v))) - (and (macro? val) - (not (syncase-macro-type val)) - val)))))) - (module-define! (current-module) - symbol - (if existing - (make-extended-syncase-macro existing type val) - (make-syncase-macro type val)))))) - -(define get-global-definition-hook - (lambda (symbol module) - (if (and (not module) (current-module)) - (warn "module system is booted, we should have a module" symbol)) - (let ((v (module-variable (if module - (resolve-module (cdr module)) - (current-module)) - symbol))) - (and v (variable-bound? v) - (let ((val (variable-ref v))) - (and (macro? val) (syncase-macro-type val) - (cons (syncase-macro-type val) - (syncase-macro-binding val)))))))) - -) - - -(define (decorate-source e s) - (if (and (pair? e) s) - (set-source-properties! e s)) - e) + (begin + (define fx+ +) + (define fx- -) + (define fx= =) + (define fx< <) + + (define top-level-eval-hook + (lambda (x mod) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (language tree-il) tree-il->scheme) x)) + (else x)))))) + + (define local-eval-hook + (lambda (x mod) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (language tree-il) tree-il->scheme) x)) + (else x)))))) + + (define-syntax gensym-hook + (syntax-rules () + ((_) (gensym)))) + + (define put-global-definition-hook + (lambda (symbol type val) + (let ((existing (let ((v (module-variable (current-module) symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) + (not (syncase-macro-type val)) + val)))))) + (module-define! (current-module) + symbol + (if existing + (make-extended-syncase-macro existing type val) + (make-syncase-macro type val)))))) + + (define get-global-definition-hook + (lambda (symbol module) + (if (and (not module) (current-module)) + (warn "module system is booted, we should have a module" symbol)) + (let ((v (module-variable (if module + (resolve-module (cdr module)) + (current-module)) + symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) (syncase-macro-type val) + (cons (syncase-macro-type val) + (syncase-macro-binding val)))))))) + + ) + + + (define (decorate-source e s) + (if (and (pair? e) s) + (set-source-properties! e s)) + e) ;;; output constructors -(define build-void - (lambda (source) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-void) source)) - (else (decorate-source '(if #f #f) source))))) - -(define build-application - (lambda (source fun-exp arg-exps) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps)) - (else (decorate-source `(,fun-exp . ,arg-exps) source))))) - -(define build-conditional - (lambda (source test-exp then-exp else-exp) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-conditional) - source test-exp then-exp else-exp)) - (else (decorate-source - (if (equal? else-exp '(if #f #f)) - `(if ,test-exp ,then-exp) - `(if ,test-exp ,then-exp ,else-exp)) - source))))) - -(define build-lexical-reference - (lambda (type source name var) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-lexical-ref) source name var)) - (else (decorate-source var source))))) + (define build-void + (lambda (source) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-void) source)) + (else (decorate-source '(if #f #f) source))))) -(define build-lexical-assignment - (lambda (source name var exp) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-lexical-set) source name var exp)) - (else (decorate-source `(set! ,var ,exp) source))))) - -;; Before modules are booted, we can't expand into data structures from -;; (language tree-il) -- we need to give the evaluator the -;; s-expressions that it understands natively. Actually the real truth -;; of the matter is that the evaluator doesn't understand tree-il -;; structures at all. So until we fix the evaluator, if ever, the -;; conflation that we should use tree-il iff we are compiling -;; holds true. -;; -(define (analyze-variable mod var modref-cont bare-cont) - (if (not mod) - (bare-cont var) - (let ((kind (car mod)) - (mod (cdr mod))) - (case kind - ((public) (modref-cont mod var #t)) - ((private) (if (not (equal? mod (module-name (current-module)))) - (modref-cont mod var #f) - (bare-cont var))) - ((bare) (bare-cont var)) - ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) - (module-variable (resolve-module mod) var)) - (modref-cont mod var #f) - (bare-cont var))) - (else (syntax-violation #f "bad module kind" var mod)))))) - -(define build-global-reference - (lambda (source var mod) - (analyze-variable - mod var - (lambda (mod var public?) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-module-ref) source mod var public?)) - (else (decorate-source (list (if public? '@ '@@) mod var) source)))) - (lambda (var) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-toplevel-ref) source var)) - (else (decorate-source var source))))))) - -(define build-global-assignment - (lambda (source var exp mod) - (analyze-variable - mod var - (lambda (mod var public?) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-module-set) source mod var public? exp)) - (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source)))) - (lambda (var) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-toplevel-set) source var exp)) - (else (decorate-source `(set! ,var ,exp) source))))))) - -;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz) -;; from working. Hack around it. -(define (maybe-name-value! name val) - (cond - (((@ (language tree-il) lambda?) val) - (let ((meta ((@ (language tree-il) lambda-meta) val))) - (if (not (assq 'name meta)) - ((setter (@ (language tree-il) lambda-meta)) - val - (acons 'name name meta))))))) - -(define build-global-definition - (lambda (source var exp) - (case (fluid-ref *mode*) - ((c) - (maybe-name-value! var exp) - ((@ (language tree-il) make-toplevel-define) source var exp)) - (else (decorate-source `(define ,var ,exp) source))))) - -;; Ideally we would have all lambdas be case lambdas, but that would -;; need special support in the interpreter for the full capabilities of -;; case-lambda, with optional and keyword args, predicates, and else -;; clauses. This will come with the new interpreter, but for now we -;; separate the cases. -(define build-simple-lambda - (lambda (src req rest vars docstring exp) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-lambda) src - (if docstring `((documentation . ,docstring)) '()) - ;; hah, a case in which kwargs would be nice. - ((@ (language tree-il) make-lambda-case) - ;; src req opt rest kw inits vars predicate body else - src req #f rest #f '() vars #f exp #f))) - (else (decorate-source - `(lambda ,(if rest (apply cons* vars) vars) - ,@(if docstring (list docstring) '()) - ,exp) - src))))) + (define build-application + (lambda (source fun-exp arg-exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps)) + (else (decorate-source `(,fun-exp . ,arg-exps) source))))) -(define build-case-lambda - (lambda (src docstring body) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-lambda) src - (if docstring `((documentation . ,docstring)) '()) - body)) - (else (decorate-source - ;; really gross hack - `(lambda %%args - ,@(if docstring (list docstring) '()) - (cond ,@body)) - src))))) - -(define build-lambda-case - ;; req := (name ...) - ;; opt := (name ...) | #f - ;; rest := name | #f - ;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f - ;; inits: (init ...) - ;; vars: (sym ...) - ;; vars map to named arguments in the following order: - ;; required, optional (positional), rest, keyword. - ;; predicate: something you can stuff in a (lambda ,vars ,pred), already expanded - ;; the body of a lambda: anything, already expanded - ;; else: lambda-case | #f - (lambda (src req opt rest kw inits vars predicate body else-case) - (case (fluid-ref *mode*) - ((c) - ((@ (language tree-il) make-lambda-case) - src req opt rest kw inits vars predicate body else-case)) - (else - ;; Very much like the logic of (language tree-il compile-glil). - (let* ((nreq (length req)) - (nopt (if opt (length opt) 0)) - (rest-idx (and rest (+ nreq nopt))) - (allow-other-keys? (if kw (car kw) #f)) - (kw-indices (map (lambda (x) - ;; (,key ,name ,var) - (cons (car x) (list-index vars (caddr x)))) - (if kw (cdr kw) '()))) - (nargs (apply max (+ nreq nopt (if rest 1 0)) - (map 1+ (map cdr kw-indices))))) - (or (= nargs - (length vars) - (+ nreq (length inits) (if rest 1 0))) - (error "something went wrong" - req opt rest kw inits vars nreq nopt kw-indices nargs)) - (decorate-source - `((((@@ (ice-9 optargs) parse-lambda-case) - '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices) - (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits)) - ,(if predicate `(lambda ,vars ,predicate) #f) - %%args) - ;; FIXME: This _ is here to work around a bug in the - ;; memoizer. The %%% makes it different from %%, also a - ;; memoizer workaround. See the "interesting bug" mail from - ;; 23 oct 2009. As soon as we change the evaluator, this - ;; can be removed. - => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args))) - ,@(or else-case - `((%%args (error "wrong number of arguments" %%args))))) - src)))))) - -(define build-primref - (lambda (src name) - (if (equal? (module-name (current-module)) '(guile)) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-toplevel-ref) src name)) - (else (decorate-source name src))) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f)) - (else (decorate-source `(@@ (guile) ,name) src)))))) - -(define (build-data src exp) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-const) src exp)) - (else (decorate-source - (if (and (self-evaluating? exp) (not (vector? exp))) - exp - (list 'quote exp)) - src)))) - -(define build-sequence - (lambda (src exps) - (if (null? (cdr exps)) - (car exps) - (case (fluid-ref *mode*) - ((c) ((@ (language tree-il) make-sequence) src exps)) - (else (decorate-source `(begin ,@exps) src)))))) + (define build-conditional + (lambda (source test-exp then-exp else-exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-conditional) + source test-exp then-exp else-exp)) + (else (decorate-source + (if (equal? else-exp '(if #f #f)) + `(if ,test-exp ,then-exp) + `(if ,test-exp ,then-exp ,else-exp)) + source))))) -(define build-let - (lambda (src ids vars val-exps body-exp) - (if (null? vars) - body-exp - (case (fluid-ref *mode*) - ((c) - (for-each maybe-name-value! ids val-exps) - ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) - (else (decorate-source - `(let ,(map list vars val-exps) ,body-exp) - src)))))) + (define build-lexical-reference + (lambda (type source name var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-ref) source name var)) + (else (decorate-source var source))))) -(define build-named-let - (lambda (src ids vars val-exps body-exp) - (let ((f (car vars)) - (f-name (car ids)) - (vars (cdr vars)) - (ids (cdr ids))) + (define build-lexical-assignment + (lambda (source name var exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-set) source name var exp)) + (else (decorate-source `(set! ,var ,exp) source))))) + + ;; Before modules are booted, we can't expand into data structures from + ;; (language tree-il) -- we need to give the evaluator the + ;; s-expressions that it understands natively. Actually the real truth + ;; of the matter is that the evaluator doesn't understand tree-il + ;; structures at all. So until we fix the evaluator, if ever, the + ;; conflation that we should use tree-il iff we are compiling + ;; holds true. + ;; + (define (analyze-variable mod var modref-cont bare-cont) + (if (not mod) + (bare-cont var) + (let ((kind (car mod)) + (mod (cdr mod))) + (case kind + ((public) (modref-cont mod var #t)) + ((private) (if (not (equal? mod (module-name (current-module)))) + (modref-cont mod var #f) + (bare-cont var))) + ((bare) (bare-cont var)) + ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + (modref-cont mod var #f) + (bare-cont var))) + (else (syntax-violation #f "bad module kind" var mod)))))) + + (define build-global-reference + (lambda (source var mod) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) source mod var public?)) + (else (decorate-source (list (if public? '@ '@@) mod var) source)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) source var)) + (else (decorate-source var source))))))) + + (define build-global-assignment + (lambda (source var exp mod) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-set) source mod var public? exp)) + (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-set) source var exp)) + (else (decorate-source `(set! ,var ,exp) source))))))) + + ;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz) + ;; from working. Hack around it. + (define (maybe-name-value! name val) + (cond + (((@ (language tree-il) lambda?) val) + (let ((meta ((@ (language tree-il) lambda-meta) val))) + (if (not (assq 'name meta)) + ((setter (@ (language tree-il) lambda-meta)) + val + (acons 'name name meta))))))) + + (define build-global-definition + (lambda (source var exp) (case (fluid-ref *mode*) ((c) - (let ((proc (build-simple-lambda src ids #f vars #f body-exp))) - (maybe-name-value! f-name proc) - (for-each maybe-name-value! ids val-exps) - ((@ (language tree-il) make-letrec) src - (list f-name) (list f) (list proc) - (build-application src (build-lexical-reference 'fun src f-name f) - val-exps)))) + (maybe-name-value! var exp) + ((@ (language tree-il) make-toplevel-define) source var exp)) + (else (decorate-source `(define ,var ,exp) source))))) + + ;; Ideally we would have all lambdas be case lambdas, but that would + ;; need special support in the interpreter for the full capabilities of + ;; case-lambda, with optional and keyword args, predicates, and else + ;; clauses. This will come with the new interpreter, but for now we + ;; separate the cases. + (define build-simple-lambda + (lambda (src req rest vars docstring exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lambda) src + (if docstring `((documentation . ,docstring)) '()) + ;; hah, a case in which kwargs would be nice. + ((@ (language tree-il) make-lambda-case) + ;; src req opt rest kw inits vars predicate body else + src req #f rest #f '() vars #f exp #f))) (else (decorate-source - `(let ,f ,(map list vars val-exps) ,body-exp) - src)))))) + `(lambda ,(if rest (apply cons* vars) vars) + ,@(if docstring (list docstring) '()) + ,exp) + src))))) -(define build-letrec - (lambda (src ids vars val-exps body-exp) - (if (null? vars) - body-exp + (define build-case-lambda + (lambda (src docstring body) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lambda) src + (if docstring `((documentation . ,docstring)) '()) + body)) + (else (decorate-source + ;; really gross hack + `(lambda %%args + ,@(if docstring (list docstring) '()) + (cond ,@body)) + src))))) + + (define build-lambda-case + ;; req := (name ...) + ;; opt := (name ...) | #f + ;; rest := name | #f + ;; kw := (allow-other-keys? (keyword name var [init]) ...) | #f + ;; inits: (init ...) + ;; vars: (sym ...) + ;; vars map to named arguments in the following order: + ;; required, optional (positional), rest, keyword. + ;; predicate: something you can stuff in a (lambda ,vars ,pred), already expanded + ;; the body of a lambda: anything, already expanded + ;; else: lambda-case | #f + (lambda (src req opt rest kw inits vars predicate body else-case) + (case (fluid-ref *mode*) + ((c) + ((@ (language tree-il) make-lambda-case) + src req opt rest kw inits vars predicate body else-case)) + (else + ;; Very much like the logic of (language tree-il compile-glil). + (let* ((nreq (length req)) + (nopt (if opt (length opt) 0)) + (rest-idx (and rest (+ nreq nopt))) + (allow-other-keys? (if kw (car kw) #f)) + (kw-indices (map (lambda (x) + ;; (,key ,name ,var) + (cons (car x) (list-index vars (caddr x)))) + (if kw (cdr kw) '()))) + (nargs (apply max (+ nreq nopt (if rest 1 0)) + (map 1+ (map cdr kw-indices))))) + (or (= nargs + (length vars) + (+ nreq (length inits) (if rest 1 0))) + (error "something went wrong" + req opt rest kw inits vars nreq nopt kw-indices nargs)) + (decorate-source + `((((@@ (ice-9 optargs) parse-lambda-case) + '(,nreq ,nopt ,rest-idx ,nargs ,allow-other-keys? ,kw-indices) + (list ,@(map (lambda (i) `(lambda ,vars ,i)) inits)) + ,(if predicate `(lambda ,vars ,predicate) #f) + %%args) + ;; FIXME: This _ is here to work around a bug in the + ;; memoizer. The %%% makes it different from %%, also a + ;; memoizer workaround. See the "interesting bug" mail from + ;; 23 oct 2009. As soon as we change the evaluator, this + ;; can be removed. + => (lambda (%%%args . _) (apply (lambda ,vars ,body) %%%args))) + ,@(or else-case + `((%%args (error "wrong number of arguments" %%args))))) + src)))))) + + (define build-primref + (lambda (src name) + (if (equal? (module-name (current-module)) '(guile)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) src name)) + (else (decorate-source name src))) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f)) + (else (decorate-source `(@@ (guile) ,name) src)))))) + + (define (build-data src exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-const) src exp)) + (else (decorate-source + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp)) + src)))) + + (define build-sequence + (lambda (src exps) + (if (null? (cdr exps)) + (car exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-sequence) src exps)) + (else (decorate-source `(begin ,@exps) src)))))) + + (define build-let + (lambda (src ids vars val-exps body-exp) + (if (null? vars) + body-exp + (case (fluid-ref *mode*) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) + (else (decorate-source + `(let ,(map list vars val-exps) ,body-exp) + src)))))) + + (define build-named-let + (lambda (src ids vars val-exps body-exp) + (let ((f (car vars)) + (f-name (car ids)) + (vars (cdr vars)) + (ids (cdr ids))) (case (fluid-ref *mode*) ((c) - (for-each maybe-name-value! ids val-exps) - ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) + (let ((proc (build-simple-lambda src ids #f vars #f body-exp))) + (maybe-name-value! f-name proc) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src + (list f-name) (list f) (list proc) + (build-application src (build-lexical-reference 'fun src f-name f) + val-exps)))) (else (decorate-source - `(letrec ,(map list vars val-exps) ,body-exp) + `(let ,f ,(map list vars val-exps) ,body-exp) src)))))) -;; FIXME: use a faster gensym -(define-syntax build-lexical-var - (syntax-rules () - ((_ src id) (gensym (string-append (symbol->string id) " "))))) + (define build-letrec + (lambda (src ids vars val-exps body-exp) + (if (null? vars) + body-exp + (case (fluid-ref *mode*) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) + (else (decorate-source + `(letrec ,(map list vars val-exps) ,body-exp) + src)))))) -(define-structure (syntax-object expression wrap module)) + ;; FIXME: use a faster gensym + (define-syntax build-lexical-var + (syntax-rules () + ((_ src id) (gensym (string-append (symbol->string id) " "))))) -(define-syntax no-source (identifier-syntax #f)) + (define-structure (syntax-object expression wrap module)) -(define source-annotation - (lambda (x) - (cond - ((syntax-object? x) - (source-annotation (syntax-object-expression x))) - ((pair? x) (let ((props (source-properties x))) - (if (pair? props) - props - #f))) - (else #f)))) - -(define-syntax arg-check - (syntax-rules () - ((_ pred? e who) - (let ((x e)) - (if (not (pred? x)) (syntax-violation who "invalid argument" x)))))) + (define-syntax no-source (identifier-syntax #f)) + + (define source-annotation + (lambda (x) + (cond + ((syntax-object? x) + (source-annotation (syntax-object-expression x))) + ((pair? x) (let ((props (source-properties x))) + (if (pair? props) + props + #f))) + (else #f)))) + + (define-syntax arg-check + (syntax-rules () + ((_ pred? e who) + (let ((x e)) + (if (not (pred? x)) (syntax-violation who "invalid argument" x)))))) ;;; compile-time environments @@ -655,7 +655,7 @@ ;;; (define-syntax) define-syntax ;;; (local-syntax . rec?) let-syntax/letrec-syntax ;;; (eval-when) eval-when -;;; (syntax . (<var> . <level>)) pattern variables +;;; #'. (<var> . <level>) pattern variables ;;; (global) assumed global variable ;;; (lexical . <var>) lexical variables ;;; (displaced-lexical) displaced lexicals @@ -683,58 +683,58 @@ ;;; 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 car) -(define binding-value cdr) - -(define-syntax null-env (identifier-syntax '())) - -(define extend-env - (lambda (labels bindings r) - (if (null? labels) - r - (extend-env (cdr labels) (cdr bindings) - (cons (cons (car labels) (car bindings)) r))))) - -(define extend-var-env - ; variant of extend-env that forms "lexical" binding - (lambda (labels vars r) - (if (null? labels) - r - (extend-var-env (cdr labels) (cdr vars) - (cons (cons (car labels) (make-binding 'lexical (car vars))) r))))) + (define-syntax make-binding + (syntax-rules (quote) + ((_ type value) (cons type value)) + ((_ 'type) '(type)) + ((_ type) (cons type '())))) + (define binding-type car) + (define binding-value cdr) + + (define-syntax null-env (identifier-syntax '())) + + (define extend-env + (lambda (labels bindings r) + (if (null? labels) + r + (extend-env (cdr labels) (cdr bindings) + (cons (cons (car labels) (car bindings)) r))))) + + (define extend-var-env + ; variant of extend-env that forms "lexical" binding + (lambda (labels vars r) + (if (null? labels) + r + (extend-var-env (cdr labels) (cdr vars) + (cons (cons (car labels) (make-binding 'lexical (car vars))) r))))) ;;; we use a "macros only" environment in expansion of local macro ;;; definitions so that their definitions can use local macros without ;;; attempting to use other lexical identifiers. -(define macros-only-env - (lambda (r) - (if (null? r) - '() - (let ((a (car r))) - (if (eq? (cadr a) 'macro) - (cons a (macros-only-env (cdr r))) - (macros-only-env (cdr r))))))) - -(define lookup - ; x may be a label or a symbol - ; although symbols are usually global, we check the environment first - ; anyway because a temporary binding may have been established by - ; fluid-let-syntax - (lambda (x r mod) - (cond - ((assq x r) => cdr) - ((symbol? x) - (or (get-global-definition-hook x mod) (make-binding 'global))) - (else (make-binding 'displaced-lexical))))) + (define macros-only-env + (lambda (r) + (if (null? r) + '() + (let ((a (car r))) + (if (eq? (cadr a) 'macro) + (cons a (macros-only-env (cdr r))) + (macros-only-env (cdr r))))))) + + (define lookup + ; x may be a label or a symbol + ; although symbols are usually global, we check the environment first + ; anyway because a temporary binding may have been established by + ; fluid-let-syntax + (lambda (x r mod) + (cond + ((assq x r) => cdr) + ((symbol? x) + (or (get-global-definition-hook x mod) (make-binding 'global))) + (else (make-binding 'displaced-lexical))))) -(define global-extend - (lambda (type sym val) - (put-global-definition-hook sym type val))) + (define global-extend + (lambda (type sym val) + (put-global-definition-hook sym type val))) ;;; Conceptually, identifiers are always syntax objects. Internally, @@ -742,33 +742,33 @@ ;;; efficiency and confusion), so that symbols are also considered ;;; identifiers by id?. Externally, they are always wrapped. -(define nonsymbol-id? - (lambda (x) - (and (syntax-object? x) - (symbol? (syntax-object-expression x))))) + (define nonsymbol-id? + (lambda (x) + (and (syntax-object? x) + (symbol? (syntax-object-expression x))))) -(define id? - (lambda (x) - (cond - ((symbol? x) #t) - ((syntax-object? x) (symbol? (syntax-object-expression x))) - (else #f)))) + (define id? + (lambda (x) + (cond + ((symbol? x) #t) + ((syntax-object? x) (symbol? (syntax-object-expression x))) + (else #f)))) -(define-syntax id-sym-name - (syntax-rules () - ((_ e) - (let ((x e)) - (if (syntax-object? x) + (define-syntax id-sym-name + (syntax-rules () + ((_ e) + (let ((x e)) + (if (syntax-object? x) + (syntax-object-expression x) + x))))) + + (define id-sym-name&marks + (lambda (x w) + (if (syntax-object? x) + (values (syntax-object-expression x) - x))))) - -(define id-sym-name&marks - (lambda (x w) - (if (syntax-object? x) - (values - (syntax-object-expression x) - (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) - (values x (wrap-marks w))))) + (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) + (values x (wrap-marks w))))) ;;; syntax object wraps @@ -777,86 +777,86 @@ ;;; <subs> ::= #(<old name> <label> (<mark> ...)) ;;; <shift> ::= positive fixnum -(define make-wrap cons) -(define wrap-marks car) -(define wrap-subst cdr) + (define make-wrap cons) + (define wrap-marks car) + (define wrap-subst cdr) -(define-syntax subst-rename? (identifier-syntax vector?)) -(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0)))) -(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1)))) -(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2)))) -(define-syntax make-rename - (syntax-rules () - ((_ old new marks) (vector old new marks)))) + (define-syntax subst-rename? (identifier-syntax vector?)) + (define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0)))) + (define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1)))) + (define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2)))) + (define-syntax make-rename + (syntax-rules () + ((_ old new marks) (vector old new marks)))) ;;; labels must be comparable with "eq?" and distinct from symbols. -(define gen-label - (lambda () (string #\i))) + (define gen-label + (lambda () (string #\i))) -(define gen-labels - (lambda (ls) - (if (null? ls) - '() - (cons (gen-label) (gen-labels (cdr ls)))))) + (define gen-labels + (lambda (ls) + (if (null? ls) + '() + (cons (gen-label) (gen-labels (cdr ls)))))) -(define-structure (ribcage symnames marks labels)) + (define-structure (ribcage symnames marks labels)) -(define-syntax empty-wrap (identifier-syntax '(()))) + (define-syntax empty-wrap (identifier-syntax '(()))) -(define-syntax top-wrap (identifier-syntax '((top)))) + (define-syntax top-wrap (identifier-syntax '((top)))) -(define-syntax top-marked? - (syntax-rules () - ((_ w) (memq 'top (wrap-marks w))))) + (define-syntax top-marked? + (syntax-rules () + ((_ w) (memq 'top (wrap-marks w))))) ;;; Marks must be comparable with "eq?" and distinct from pairs and ;;; the symbol top. We do not use integers so that marks will remain ;;; unique even across file compiles. -(define-syntax the-anti-mark (identifier-syntax #f)) + (define-syntax the-anti-mark (identifier-syntax #f)) -(define anti-mark - (lambda (w) - (make-wrap (cons the-anti-mark (wrap-marks w)) - (cons 'shift (wrap-subst w))))) + (define anti-mark + (lambda (w) + (make-wrap (cons the-anti-mark (wrap-marks w)) + (cons 'shift (wrap-subst w))))) -(define-syntax new-mark - (syntax-rules () - ((_) (string #\m)))) + (define-syntax new-mark + (syntax-rules () + ((_) (string #\m)))) ;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for ;;; internal definitions, in which the ribcages are built incrementally -(define-syntax make-empty-ribcage - (syntax-rules () - ((_) (make-ribcage '() '() '())))) - -(define extend-ribcage! - ; must receive ids with complete wraps - (lambda (ribcage id label) - (set-ribcage-symnames! ribcage - (cons (syntax-object-expression id) - (ribcage-symnames ribcage))) - (set-ribcage-marks! ribcage - (cons (wrap-marks (syntax-object-wrap id)) - (ribcage-marks ribcage))) - (set-ribcage-labels! ribcage - (cons label (ribcage-labels ribcage))))) + (define-syntax make-empty-ribcage + (syntax-rules () + ((_) (make-ribcage '() '() '())))) + + (define extend-ribcage! + ; must receive ids with complete wraps + (lambda (ribcage id label) + (set-ribcage-symnames! ribcage + (cons (syntax-object-expression id) + (ribcage-symnames ribcage))) + (set-ribcage-marks! ribcage + (cons (wrap-marks (syntax-object-wrap id)) + (ribcage-marks ribcage))) + (set-ribcage-labels! ribcage + (cons label (ribcage-labels ribcage))))) ;;; make-binding-wrap creates vector-based ribcages -(define make-binding-wrap - (lambda (ids labels w) - (if (null? ids) - w - (make-wrap - (wrap-marks w) - (cons + (define make-binding-wrap + (lambda (ids labels w) + (if (null? ids) + w + (make-wrap + (wrap-marks w) + (cons (let ((labelvec (list->vector labels))) (let ((n (vector-length labelvec))) (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) (let f ((ids ids) (i 0)) (if (not (null? ids)) (call-with-values - (lambda () (id-sym-name&marks (car ids) w)) + (lambda () (id-sym-name&marks (car ids) w)) (lambda (symname marks) (vector-set! symnamevec i symname) (vector-set! marksvec i marks) @@ -864,76 +864,76 @@ (make-ribcage symnamevec marksvec labelvec)))) (wrap-subst w)))))) -(define smart-append - (lambda (m1 m2) - (if (null? m2) - m1 - (append m1 m2)))) - -(define join-wraps - (lambda (w1 w2) - (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1))) - (if (null? m1) - (if (null? s1) - w2 - (make-wrap - (wrap-marks w2) - (smart-append s1 (wrap-subst w2)))) - (make-wrap - (smart-append m1 (wrap-marks w2)) - (smart-append s1 (wrap-subst w2))))))) - -(define join-marks - (lambda (m1 m2) - (smart-append m1 m2))) - -(define same-marks? - (lambda (x y) - (or (eq? x y) - (and (not (null? x)) - (not (null? y)) - (eq? (car x) (car y)) - (same-marks? (cdr x) (cdr y)))))) - -(define id-var-name - (lambda (id w) - (define-syntax first - (syntax-rules () - ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x))))) - (define search - (lambda (sym subst marks) - (if (null? subst) - (values #f marks) - (let ((fst (car subst))) - (if (eq? fst 'shift) - (search sym (cdr subst) (cdr marks)) - (let ((symnames (ribcage-symnames fst))) - (if (vector? symnames) - (search-vector-rib sym subst marks symnames fst) - (search-list-rib sym subst marks symnames fst)))))))) - (define search-list-rib - (lambda (sym subst marks symnames ribcage) - (let f ((symnames symnames) (i 0)) - (cond - ((null? symnames) (search sym (cdr subst) marks)) - ((and (eq? (car symnames) sym) - (same-marks? marks (list-ref (ribcage-marks ribcage) i))) - (values (list-ref (ribcage-labels ribcage) i) marks)) - (else (f (cdr symnames) (fx+ i 1))))))) - (define search-vector-rib - (lambda (sym subst marks symnames ribcage) - (let ((n (vector-length symnames))) - (let f ((i 0)) + (define smart-append + (lambda (m1 m2) + (if (null? m2) + m1 + (append m1 m2)))) + + (define join-wraps + (lambda (w1 w2) + (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1))) + (if (null? m1) + (if (null? s1) + w2 + (make-wrap + (wrap-marks w2) + (smart-append s1 (wrap-subst w2)))) + (make-wrap + (smart-append m1 (wrap-marks w2)) + (smart-append s1 (wrap-subst w2))))))) + + (define join-marks + (lambda (m1 m2) + (smart-append m1 m2))) + + (define same-marks? + (lambda (x y) + (or (eq? x y) + (and (not (null? x)) + (not (null? y)) + (eq? (car x) (car y)) + (same-marks? (cdr x) (cdr y)))))) + + (define id-var-name + (lambda (id w) + (define-syntax first + (syntax-rules () + ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x))))) + (define search + (lambda (sym subst marks) + (if (null? subst) + (values #f marks) + (let ((fst (car subst))) + (if (eq? fst 'shift) + (search sym (cdr subst) (cdr marks)) + (let ((symnames (ribcage-symnames fst))) + (if (vector? symnames) + (search-vector-rib sym subst marks symnames fst) + (search-list-rib sym subst marks symnames fst)))))))) + (define search-list-rib + (lambda (sym subst marks symnames ribcage) + (let f ((symnames symnames) (i 0)) (cond - ((fx= i n) (search sym (cdr subst) marks)) - ((and (eq? (vector-ref symnames i) sym) - (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) - (values (vector-ref (ribcage-labels ribcage) i) marks)) - (else (f (fx+ i 1)))))))) - (cond - ((symbol? id) - (or (first (search id (wrap-subst w) (wrap-marks w))) id)) - ((syntax-object? id) + ((null? symnames) (search sym (cdr subst) marks)) + ((and (eq? (car symnames) sym) + (same-marks? marks (list-ref (ribcage-marks ribcage) i))) + (values (list-ref (ribcage-labels ribcage) i) marks)) + (else (f (cdr symnames) (fx+ i 1))))))) + (define search-vector-rib + (lambda (sym subst marks symnames ribcage) + (let ((n (vector-length symnames))) + (let f ((i 0)) + (cond + ((fx= i n) (search sym (cdr subst) marks)) + ((and (eq? (vector-ref symnames i) sym) + (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) + (values (vector-ref (ribcage-labels ribcage) i) marks)) + (else (f (fx+ i 1)))))))) + (cond + ((symbol? id) + (or (first (search id (wrap-subst w) (wrap-marks w))) id)) + ((syntax-object? id) (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) @@ -942,41 +942,41 @@ (or new-id (first (search id (wrap-subst w1) marks)) id)))))) - (else (syntax-violation 'id-var-name "invalid id" id))))) + (else (syntax-violation 'id-var-name "invalid id" id))))) ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y) ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. -(define free-id=? - (lambda (i j) - (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator - (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap))))) + (define free-id=? + (lambda (i j) + (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator + (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap))))) ;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as ;;; long as the missing portion of the wrap is common to both of the ids ;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w)) -(define bound-id=? - (lambda (i j) - (if (and (syntax-object? i) (syntax-object? j)) - (and (eq? (syntax-object-expression i) - (syntax-object-expression j)) - (same-marks? (wrap-marks (syntax-object-wrap i)) - (wrap-marks (syntax-object-wrap j)))) - (eq? i j)))) + (define bound-id=? + (lambda (i j) + (if (and (syntax-object? i) (syntax-object? j)) + (and (eq? (syntax-object-expression i) + (syntax-object-expression j)) + (same-marks? (wrap-marks (syntax-object-wrap i)) + (wrap-marks (syntax-object-wrap j)))) + (eq? i j)))) ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids ;;; as long as the missing portion of the wrap is common to all of the ;;; ids. -(define valid-bound-ids? - (lambda (ids) - (and (let all-ids? ((ids ids)) - (or (null? ids) - (and (id? (car ids)) - (all-ids? (cdr ids))))) - (distinct-bound-ids? ids)))) + (define valid-bound-ids? + (lambda (ids) + (and (let all-ids? ((ids ids)) + (or (null? ids) + (and (id? (car ids)) + (all-ids? (cdr ids))))) + (distinct-bound-ids? ids)))) ;;; distinct-bound-ids? expects a list of ids and returns #t if there are ;;; no duplicates. It is quadratic on the length of the id list; long @@ -984,101 +984,101 @@ ;;; may be passed unwrapped (or partially wrapped) ids as long as the ;;; missing portion of the wrap is common to all of the ids. -(define distinct-bound-ids? - (lambda (ids) - (let distinct? ((ids ids)) - (or (null? ids) - (and (not (bound-id-member? (car ids) (cdr ids))) - (distinct? (cdr ids))))))) + (define distinct-bound-ids? + (lambda (ids) + (let distinct? ((ids ids)) + (or (null? ids) + (and (not (bound-id-member? (car ids) (cdr ids))) + (distinct? (cdr ids))))))) -(define bound-id-member? - (lambda (x list) + (define bound-id-member? + (lambda (x list) (and (not (null? list)) (or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) ;;; wrapping expressions and identifiers -(define wrap - (lambda (x w defmod) - (cond - ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x) - ((syntax-object? x) - (make-syntax-object + (define wrap + (lambda (x w defmod) + (cond + ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x) + ((syntax-object? x) + (make-syntax-object (syntax-object-expression x) (join-wraps w (syntax-object-wrap x)) (syntax-object-module x))) - ((null? x) x) - (else (make-syntax-object x w defmod))))) + ((null? x) x) + (else (make-syntax-object x w defmod))))) -(define source-wrap - (lambda (x w s defmod) - (wrap (decorate-source x s) w defmod))) + (define source-wrap + (lambda (x w s defmod) + (wrap (decorate-source x s) w defmod))) ;;; expanding -(define chi-sequence - (lambda (body r w s mod) - (build-sequence s - (let dobody ((body body) (r r) (w w) (mod mod)) - (if (null? body) - '() - (let ((first (chi (car body) r w mod))) - (cons first (dobody (cdr body) r w mod)))))))) - -(define chi-top-sequence - (lambda (body r w s m esew mod) - (build-sequence s - (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod)) - (if (null? body) - '() - (let ((first (chi-top (car body) r w m esew mod))) - (cons first (dobody (cdr body) r w m esew mod)))))))) - -(define chi-install-global - (lambda (name e) - (build-global-definition - no-source - name - ;; FIXME: seems nasty to call current-module here - (if (let ((v (module-variable (current-module) name))) - ;; FIXME use primitive-macro? - (and v (variable-bound? v) (macro? (variable-ref v)) - (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) - (build-application - no-source - (build-primref no-source 'make-extended-syncase-macro) - (list (build-application - no-source - (build-primref no-source 'module-ref) - (list (build-application - no-source - (build-primref no-source 'current-module) - '()) - (build-data no-source name))) - (build-data no-source 'macro) - e)) - (build-application - no-source - (build-primref no-source 'make-syncase-macro) - (list (build-data no-source 'macro) e)))))) - -(define chi-when-list - (lambda (e when-list w) - ; when-list is syntax'd version of list of situations - (let f ((when-list when-list) (situations '())) - (if (null? when-list) - situations - (f (cdr when-list) - (cons (let ((x (car when-list))) - (cond - ((free-id=? x (syntax compile)) 'compile) - ((free-id=? x (syntax load)) 'load) - ((free-id=? x (syntax eval)) 'eval) - (else (syntax-violation 'eval-when - "invalid situation" - e (wrap x w #f))))) - situations)))))) + (define chi-sequence + (lambda (body r w s mod) + (build-sequence s + (let dobody ((body body) (r r) (w w) (mod mod)) + (if (null? body) + '() + (let ((first (chi (car body) r w mod))) + (cons first (dobody (cdr body) r w mod)))))))) + + (define chi-top-sequence + (lambda (body r w s m esew mod) + (build-sequence s + (let dobody ((body body) (r r) (w w) (m m) (esew esew) (mod mod)) + (if (null? body) + '() + (let ((first (chi-top (car body) r w m esew mod))) + (cons first (dobody (cdr body) r w m esew mod)))))))) + + (define chi-install-global + (lambda (name e) + (build-global-definition + no-source + name + ;; FIXME: seems nasty to call current-module here + (if (let ((v (module-variable (current-module) name))) + ;; FIXME use primitive-macro? + (and v (variable-bound? v) (macro? (variable-ref v)) + (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) + (build-application + no-source + (build-primref no-source 'make-extended-syncase-macro) + (list (build-application + no-source + (build-primref no-source 'module-ref) + (list (build-application + no-source + (build-primref no-source 'current-module) + '()) + (build-data no-source name))) + (build-data no-source 'macro) + e)) + (build-application + no-source + (build-primref no-source 'make-syncase-macro) + (list (build-data no-source 'macro) e)))))) + + (define chi-when-list + (lambda (e when-list w) + ; when-list is syntax'd version of list of situations + (let f ((when-list when-list) (situations '())) + (if (null? when-list) + situations + (f (cdr when-list) + (cons (let ((x (car when-list))) + (cond + ((free-id=? x #'compile) 'compile) + ((free-id=? x #'load) 'load) + ((free-id=? x #'eval) 'eval) + (else (syntax-violation 'eval-when + "invalid situation" + e (wrap x w #f))))) + situations)))))) ;;; syntax-type returns six values: type, value, e, w, s, and mod. The ;;; first two are described in the table below. @@ -1116,684 +1116,684 @@ ;;; one of the forms above. It also parses define and define-syntax ;;; forms, although perhaps this should be done by the consumer. -(define syntax-type - (lambda (e r w s rib mod for-car?) - (cond - ((symbol? e) - (let* ((n (id-var-name e w)) - (b (lookup n r mod)) - (type (binding-type b))) - (case type - ((lexical) (values type (binding-value b) e w s mod)) - ((global) (values type n e w s mod)) - ((macro) - (if for-car? - (values type (binding-value b) e w s mod) - (syntax-type (chi-macro (binding-value b) e r w rib mod) - r empty-wrap s rib mod #f))) - (else (values type (binding-value b) 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 fe fw fs fmod) - (case ftype - ((lexical) - (values 'lexical-call fval e w s mod)) - ((global) - ;; 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-object fval w fmod) - e w s mod)) - ((macro) - (syntax-type (chi-macro fval e r w rib mod) - r empty-wrap s rib mod for-car?)) - ((module-ref) - (call-with-values (lambda () (fval e)) - (lambda (sym mod) - (syntax-type sym r w s rib mod for-car?)))) - ((core) - (values 'core-form fval e w s mod)) - ((local-syntax) - (values 'local-syntax-form fval e w s mod)) - ((begin) - (values 'begin-form #f e w s mod)) - ((eval-when) - (values 'eval-when-form #f e w s mod)) - ((define) - (syntax-case e () - ((_ name val) - (id? (syntax name)) - (values 'define-form (syntax name) (syntax val) w s mod)) - ((_ (name . args) e1 e2 ...) - (and (id? (syntax name)) - (valid-bound-ids? (lambda-var-list (syntax args)))) + (define syntax-type + (lambda (e r w s rib mod for-car?) + (cond + ((symbol? e) + (let* ((n (id-var-name e w)) + (b (lookup n r mod)) + (type (binding-type b))) + (case type + ((lexical) (values type (binding-value b) e w s mod)) + ((global) (values type n e w s mod)) + ((macro) + (if for-car? + (values type (binding-value b) e w s mod) + (syntax-type (chi-macro (binding-value b) e r w rib mod) + r empty-wrap s rib mod #f))) + (else (values type (binding-value b) 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 fe fw fs fmod) + (case ftype + ((lexical) + (values 'lexical-call fval e w s mod)) + ((global) + ;; 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-object fval w fmod) + e w s mod)) + ((macro) + (syntax-type (chi-macro fval e r w rib mod) + r empty-wrap s rib mod for-car?)) + ((module-ref) + (call-with-values (lambda () (fval e)) + (lambda (sym mod) + (syntax-type sym r w s rib mod for-car?)))) + ((core) + (values 'core-form fval e w s mod)) + ((local-syntax) + (values 'local-syntax-form fval e w s mod)) + ((begin) + (values 'begin-form #f e w s mod)) + ((eval-when) + (values 'eval-when-form #f e w s mod)) + ((define) + (syntax-case e () + ((_ name val) + (id? #'name) + (values 'define-form #'name #'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 (syntax name) w mod) - (decorate-source - (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w mod)) - s) - empty-wrap s mod)) - ((_ name) - (id? (syntax name)) - (values 'define-form (wrap (syntax name) w mod) - (syntax (if #f #f)) - empty-wrap s mod)))) - ((define-syntax) - (syntax-case e () - ((_ name val) - (id? (syntax name)) - (values 'define-syntax-form (syntax name) - (syntax val) w s mod)))) - (else - (values 'call #f e w s mod))))))) - ((syntax-object? e) - (syntax-type (syntax-object-expression e) - r - (join-wraps w (syntax-object-wrap e)) - s rib (or (syntax-object-module e) mod) for-car?)) - ((self-evaluating? e) (values 'constant #f e w s mod)) - (else (values 'other #f e w s mod))))) - -(define chi-top - (lambda (e r w m esew mod) - (define-syntax eval-if-c&e - (syntax-rules () - ((_ m e mod) - (let ((x e)) - (if (eq? m 'c&e) (top-level-eval-hook x mod)) - x)))) - (call-with-values - (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) - (lambda (type value e w s mod) - (case type - ((begin-form) - (syntax-case e () - ((_) (chi-void)) - ((_ e1 e2 ...) - (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew mod)))) - ((local-syntax-form) - (chi-local-syntax value e r w s mod - (lambda (body r w s mod) - (chi-top-sequence body r w s m esew mod)))) - ((eval-when-form) - (syntax-case e () - ((_ (x ...) e1 e2 ...) - (let ((when-list (chi-when-list e (syntax (x ...)) w)) - (body (syntax (e1 e2 ...)))) - (cond - ((eq? m 'e) - (if (memq 'eval when-list) - (chi-top-sequence body r w s 'e '(eval) mod) - (chi-void))) - ((memq 'load when-list) - (if (or (memq 'compile when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (chi-top-sequence body r w s 'c&e '(compile load) mod) - (if (memq m '(c c&e)) - (chi-top-sequence body r w s 'c '(load) mod) - (chi-void)))) - ((or (memq 'compile when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (top-level-eval-hook + (values 'define-form (wrap #'name w mod) + (decorate-source + (cons #'lambda (wrap #'(args e1 e2 ...) w mod)) + s) + empty-wrap s mod)) + ((_ name) + (id? #'name) + (values 'define-form (wrap #'name w mod) + #'(if #f #f) + empty-wrap s mod)))) + ((define-syntax) + (syntax-case e () + ((_ name val) + (id? #'name) + (values 'define-syntax-form #'name + #'val w s mod)))) + (else + (values 'call #f e w s mod))))))) + ((syntax-object? e) + (syntax-type (syntax-object-expression e) + r + (join-wraps w (syntax-object-wrap e)) + s rib (or (syntax-object-module e) mod) for-car?)) + ((self-evaluating? e) (values 'constant #f e w s mod)) + (else (values 'other #f e w s mod))))) + + (define chi-top + (lambda (e r w m esew mod) + (define-syntax eval-if-c&e + (syntax-rules () + ((_ m e mod) + (let ((x e)) + (if (eq? m 'c&e) (top-level-eval-hook x mod)) + x)))) + (call-with-values + (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) + (lambda (type value e w s mod) + (case type + ((begin-form) + (syntax-case e () + ((_) (chi-void)) + ((_ e1 e2 ...) + (chi-top-sequence #'(e1 e2 ...) r w s m esew mod)))) + ((local-syntax-form) + (chi-local-syntax value e r w s mod + (lambda (body r w s mod) + (chi-top-sequence body r w s m esew mod)))) + ((eval-when-form) + (syntax-case e () + ((_ (x ...) e1 e2 ...) + (let ((when-list (chi-when-list e #'(x ...) w)) + (body #'(e1 e2 ...))) + (cond + ((eq? m 'e) + (if (memq 'eval when-list) + (chi-top-sequence body r w s 'e '(eval) mod) + (chi-void))) + ((memq 'load when-list) + (if (or (memq 'compile when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (chi-top-sequence body r w s 'c&e '(compile load) mod) + (if (memq m '(c c&e)) + (chi-top-sequence body r w s 'c '(load) mod) + (chi-void)))) + ((or (memq 'compile when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (top-level-eval-hook (chi-top-sequence body r w s 'e '(eval) mod) mod) - (chi-void)) - (else (chi-void))))))) - ((define-syntax-form) - (let ((n (id-var-name value w)) (r (macros-only-env r))) - (case m - ((c) - (if (memq 'compile esew) - (let ((e (chi-install-global n (chi e r w mod)))) - (top-level-eval-hook e mod) - (if (memq 'load esew) e (chi-void))) - (if (memq 'load esew) - (chi-install-global n (chi e r w mod)) - (chi-void)))) - ((c&e) - (let ((e (chi-install-global n (chi e r w mod)))) - (top-level-eval-hook e mod) - e)) - (else - (if (memq 'eval esew) - (top-level-eval-hook - (chi-install-global n (chi e r w mod)) - mod)) - (chi-void))))) - ((define-form) - (let* ((n (id-var-name value w)) - (type (binding-type (lookup n r mod)))) - (case type - ((global core macro module-ref) - ;; affect compile-time environment (once we have booted) - (if (and (not (module-local-variable (current-module) n)) - (current-module)) - (let ((old (module-variable (current-module) n))) - ;; use value of the same-named imported variable, if - ;; any - (module-define! (current-module) n - (if (variable? old) - (variable-ref old) - #f)))) - (eval-if-c&e m - (build-global-definition s n (chi e r w mod)) - mod)) - ((displaced-lexical) - (syntax-violation #f "identifier out of context" - e (wrap value w mod))) - (else - (syntax-violation #f "cannot define keyword at top level" - e (wrap value w mod)))))) - (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) - -(define chi - (lambda (e r w mod) - (call-with-values - (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) - (lambda (type value e w s mod) - (chi-expr type value e r w s mod))))) - -(define chi-expr - (lambda (type value e r w s mod) - (case type - ((lexical) - (build-lexical-reference 'value s e value)) - ((core core-form) - ;; apply transformer - (value e r w s mod)) - ((module-ref) - (call-with-values (lambda () (value e)) - ;; we could add a public? arg here - (lambda (id mod) (build-global-reference s id mod)))) - ((lexical-call) - (chi-application - (build-lexical-reference 'fun (source-annotation (car e)) - (car e) value) - e r w s mod)) - ((global-call) - (chi-application - (build-global-reference (source-annotation (car e)) - (if (syntax-object? value) - (syntax-object-expression value) - value) - (if (syntax-object? value) - (syntax-object-module value) - mod)) - e r w s mod)) - ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) - ((global) (build-global-reference s value mod)) - ((call) (chi-application (chi (car e) r w mod) e r w s mod)) - ((begin-form) - (syntax-case e () - ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s mod)))) - ((local-syntax-form) - (chi-local-syntax value e r w s mod chi-sequence)) - ((eval-when-form) - (syntax-case e () - ((_ (x ...) e1 e2 ...) - (let ((when-list (chi-when-list e (syntax (x ...)) w))) - (if (memq 'eval when-list) - (chi-sequence (syntax (e1 e2 ...)) r w s mod) - (chi-void)))))) - ((define-form define-syntax-form) - (syntax-violation #f "definition in expression context" - e (wrap value w 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 chi-application - (lambda (x e r w s mod) - (syntax-case e () - ((e0 e1 ...) - (build-application s x - (map (lambda (e) (chi e r w mod)) (syntax (e1 ...)))))))) - -(define chi-macro - (lambda (p e r w rib mod) - (define rebuild-macro-output - (lambda (x m) - (cond ((pair? x) - (cons (rebuild-macro-output (car x) m) - (rebuild-macro-output (cdr x) m))) - ((syntax-object? x) - (let ((w (syntax-object-wrap x))) - (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-syntax-object - (syntax-object-expression x) - (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) - (syntax-object-module x)) - ;; output introduced by macro - (make-syntax-object - (syntax-object-expression x) - (make-wrap (cons m ms) - (if rib - (cons rib (cons 'shift s)) - (cons 'shift s))) - (let ((pmod (procedure-module p))) - (if pmod - ;; hither the hygiene - (cons 'hygiene (module-name pmod)) - ;; but it's possible for the proc to have - ;; no mod, if it was made before modules - ;; were booted - '(hygiene guile)))))))) - ((vector? x) - (let* ((n (vector-length x)) (v (make-vector n))) - (do ((i 0 (fx+ i 1))) - ((fx= i n) v) + (chi-void)) + (else (chi-void))))))) + ((define-syntax-form) + (let ((n (id-var-name value w)) (r (macros-only-env r))) + (case m + ((c) + (if (memq 'compile esew) + (let ((e (chi-install-global n (chi e r w mod)))) + (top-level-eval-hook e mod) + (if (memq 'load esew) e (chi-void))) + (if (memq 'load esew) + (chi-install-global n (chi e r w mod)) + (chi-void)))) + ((c&e) + (let ((e (chi-install-global n (chi e r w mod)))) + (top-level-eval-hook e mod) + e)) + (else + (if (memq 'eval esew) + (top-level-eval-hook + (chi-install-global n (chi e r w mod)) + mod)) + (chi-void))))) + ((define-form) + (let* ((n (id-var-name value w)) + (type (binding-type (lookup n r mod)))) + (case type + ((global core macro module-ref) + ;; affect compile-time environment (once we have booted) + (if (and (not (module-local-variable (current-module) n)) + (current-module)) + (let ((old (module-variable (current-module) n))) + ;; use value of the same-named imported variable, if + ;; any + (module-define! (current-module) n + (if (variable? old) + (variable-ref old) + #f)))) + (eval-if-c&e m + (build-global-definition s n (chi e r w mod)) + mod)) + ((displaced-lexical) + (syntax-violation #f "identifier out of context" + e (wrap value w mod))) + (else + (syntax-violation #f "cannot define keyword at top level" + e (wrap value w mod)))))) + (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) + + (define chi + (lambda (e r w mod) + (call-with-values + (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) + (lambda (type value e w s mod) + (chi-expr type value e r w s mod))))) + + (define chi-expr + (lambda (type value e r w s mod) + (case type + ((lexical) + (build-lexical-reference 'value s e value)) + ((core core-form) + ;; apply transformer + (value e r w s mod)) + ((module-ref) + (call-with-values (lambda () (value e)) + ;; we could add a public? arg here + (lambda (id mod) (build-global-reference s id mod)))) + ((lexical-call) + (chi-application + (build-lexical-reference 'fun (source-annotation (car e)) + (car e) value) + e r w s mod)) + ((global-call) + (chi-application + (build-global-reference (source-annotation (car e)) + (if (syntax-object? value) + (syntax-object-expression value) + value) + (if (syntax-object? value) + (syntax-object-module value) + mod)) + e r w s mod)) + ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) + ((global) (build-global-reference s value mod)) + ((call) (chi-application (chi (car e) r w mod) e r w s mod)) + ((begin-form) + (syntax-case e () + ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod)))) + ((local-syntax-form) + (chi-local-syntax value e r w s mod chi-sequence)) + ((eval-when-form) + (syntax-case e () + ((_ (x ...) e1 e2 ...) + (let ((when-list (chi-when-list e #'(x ...) w))) + (if (memq 'eval when-list) + (chi-sequence #'(e1 e2 ...) r w s mod) + (chi-void)))))) + ((define-form define-syntax-form) + (syntax-violation #f "definition in expression context" + e (wrap value w 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 chi-application + (lambda (x e r w s mod) + (syntax-case e () + ((e0 e1 ...) + (build-application s x + (map (lambda (e) (chi e r w mod)) #'(e1 ...))))))) + + (define chi-macro + (lambda (p e r w rib mod) + (define rebuild-macro-output + (lambda (x m) + (cond ((pair? x) + (cons (rebuild-macro-output (car x) m) + (rebuild-macro-output (cdr x) m))) + ((syntax-object? x) + (let ((w (syntax-object-wrap x))) + (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-syntax-object + (syntax-object-expression x) + (make-wrap (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) + (syntax-object-module x)) + ;; output introduced by macro + (make-syntax-object + (syntax-object-expression x) + (make-wrap (cons m ms) + (if rib + (cons rib (cons 'shift s)) + (cons 'shift s))) + (let ((pmod (procedure-module p))) + (if pmod + ;; hither the hygiene + (cons 'hygiene (module-name pmod)) + ;; but it's possible for the proc to have + ;; no mod, if it was made before modules + ;; were booted + '(hygiene guile)))))))) + ((vector? x) + (let* ((n (vector-length x)) (v (make-vector n))) + (do ((i 0 (fx+ i 1))) + ((fx= i n) v) (vector-set! v i - (rebuild-macro-output (vector-ref x i) m))))) - ((symbol? x) - (syntax-violation #f "encountered raw symbol in macro output" - (source-wrap e w (wrap-subst w) mod) x)) - (else x)))) - (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark)))) - -(define chi-body - ;; In processing the forms of the body, we create a new, empty wrap. - ;; This wrap is augmented (destructively) each time we discover that - ;; the next form is a definition. This is done: - ;; - ;; (1) to allow the first nondefinition form to be a call to - ;; one of the defined ids even if the id previously denoted a - ;; definition keyword or keyword for a macro expanding into a - ;; definition; - ;; (2) to prevent subsequent definition forms (but unfortunately - ;; not earlier ones) and the first nondefinition form from - ;; confusing one of the bound identifiers for an auxiliary - ;; keyword; and - ;; (3) so that we do not need to restart the expansion of the - ;; first nondefinition form, which is problematic anyway - ;; since it might be the first element of a begin that we - ;; have just spliced into the body (meaning if we restarted, - ;; we'd really need to restart with the begin or the macro - ;; call that expanded into the begin, and we'd have to give - ;; up allowing (begin <defn>+ <expr>+), which is itself - ;; problematic since we don't know if a begin contains only - ;; definitions until we've expanded it). - ;; - ;; Before processing the body, we also create a new environment - ;; containing a placeholder for the bindings we will add later and - ;; associate this environment with each form. In processing a - ;; let-syntax or letrec-syntax, the associated environment may be - ;; augmented with local keyword bindings, so the environment may - ;; be different for different forms in the body. Once we have - ;; gathered up all of the definitions, we evaluate the transformer - ;; expressions and splice into r at the placeholder the new variable - ;; and keyword bindings. This allows let-syntax or letrec-syntax - ;; forms local to a portion or all of the body to shadow the - ;; definition bindings. - ;; - ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced - ;; into the body. - ;; - ;; outer-form is fully wrapped w/source - (lambda (body outer-form r w mod) - (let* ((r (cons '("placeholder" . (placeholder)) r)) - (ribcage (make-empty-ribcage)) - (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) - (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) - (ids '()) (labels '()) - (var-ids '()) (vars '()) (vals '()) (bindings '())) - (if (null? body) - (syntax-violation #f "no expressions in body" outer-form) - (let ((e (cdar body)) (er (caar body))) - (call-with-values - (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f)) - (lambda (type value e w s mod) - (case type - ((define-form) - (let ((id (wrap value w mod)) (label (gen-label))) - (let ((var (gen-var id))) + (rebuild-macro-output (vector-ref x i) m))))) + ((symbol? x) + (syntax-violation #f "encountered raw symbol in macro output" + (source-wrap e w (wrap-subst w) mod) x)) + (else x)))) + (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark)))) + + (define chi-body + ;; In processing the forms of the body, we create a new, empty wrap. + ;; This wrap is augmented (destructively) each time we discover that + ;; the next form is a definition. This is done: + ;; + ;; (1) to allow the first nondefinition form to be a call to + ;; one of the defined ids even if the id previously denoted a + ;; definition keyword or keyword for a macro expanding into a + ;; definition; + ;; (2) to prevent subsequent definition forms (but unfortunately + ;; not earlier ones) and the first nondefinition form from + ;; confusing one of the bound identifiers for an auxiliary + ;; keyword; and + ;; (3) so that we do not need to restart the expansion of the + ;; first nondefinition form, which is problematic anyway + ;; since it might be the first element of a begin that we + ;; have just spliced into the body (meaning if we restarted, + ;; we'd really need to restart with the begin or the macro + ;; call that expanded into the begin, and we'd have to give + ;; up allowing (begin <defn>+ <expr>+), which is itself + ;; problematic since we don't know if a begin contains only + ;; definitions until we've expanded it). + ;; + ;; Before processing the body, we also create a new environment + ;; containing a placeholder for the bindings we will add later and + ;; associate this environment with each form. In processing a + ;; let-syntax or letrec-syntax, the associated environment may be + ;; augmented with local keyword bindings, so the environment may + ;; be different for different forms in the body. Once we have + ;; gathered up all of the definitions, we evaluate the transformer + ;; expressions and splice into r at the placeholder the new variable + ;; and keyword bindings. This allows let-syntax or letrec-syntax + ;; forms local to a portion or all of the body to shadow the + ;; definition bindings. + ;; + ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced + ;; into the body. + ;; + ;; outer-form is fully wrapped w/source + (lambda (body outer-form r w mod) + (let* ((r (cons '("placeholder" . (placeholder)) r)) + (ribcage (make-empty-ribcage)) + (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) + (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) + (ids '()) (labels '()) + (var-ids '()) (vars '()) (vals '()) (bindings '())) + (if (null? body) + (syntax-violation #f "no expressions in body" outer-form) + (let ((e (cdar body)) (er (caar body))) + (call-with-values + (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod #f)) + (lambda (type value 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 (cdr body) + (cons id ids) (cons label labels) + (cons id var-ids) + (cons var vars) (cons (cons er (wrap e w mod)) vals) + (cons (make-binding 'lexical var) bindings))))) + ((define-syntax-form) + (let ((id (wrap value w mod)) (label (gen-label))) (extend-ribcage! ribcage id label) (parse (cdr body) - (cons id ids) (cons label labels) - (cons id var-ids) - (cons var vars) (cons (cons er (wrap e w mod)) vals) - (cons (make-binding 'lexical var) bindings))))) - ((define-syntax-form) - (let ((id (wrap value w mod)) (label (gen-label))) - (extend-ribcage! ribcage id label) - (parse (cdr body) - (cons id ids) (cons label labels) - var-ids vars vals - (cons (make-binding 'macro (cons er (wrap e w mod))) - bindings)))) - ((begin-form) - (syntax-case e () - ((_ e1 ...) - (parse (let f ((forms (syntax (e1 ...)))) - (if (null? forms) - (cdr body) - (cons (cons er (wrap (car forms) w mod)) - (f (cdr forms))))) - ids labels var-ids vars vals bindings)))) - ((local-syntax-form) - (chi-local-syntax value e er w s mod - (lambda (forms er w s mod) - (parse (let f ((forms forms)) - (if (null? forms) - (cdr body) - (cons (cons er (wrap (car forms) w mod)) - (f (cdr forms))))) - ids labels var-ids vars vals bindings)))) - (else ; found a non-definition - (if (null? ids) - (build-sequence no-source - (map (lambda (x) - (chi (cdr x) (car x) empty-wrap mod)) - (cons (cons er (source-wrap e w s mod)) - (cdr body)))) - (begin - (if (not (valid-bound-ids? ids)) - (syntax-violation - #f "invalid or duplicate identifier in definition" - outer-form)) - (let loop ((bs bindings) (er-cache #f) (r-cache #f)) - (if (not (null? bs)) - (let* ((b (car bs))) - (if (eq? (car b) 'macro) - (let* ((er (cadr b)) - (r-cache - (if (eq? er er-cache) - r-cache - (macros-only-env er)))) - (set-cdr! b - (eval-local-transformer - (chi (cddr b) r-cache empty-wrap mod) - mod)) - (loop (cdr bs) er r-cache)) - (loop (cdr bs) er-cache r-cache))))) - (set-cdr! r (extend-env labels bindings (cdr r))) - (build-letrec no-source - (map syntax->datum var-ids) - vars - (map (lambda (x) - (chi (cdr x) (car x) empty-wrap mod)) - vals) - (build-sequence no-source - (map (lambda (x) - (chi (cdr x) (car x) empty-wrap mod)) - (cons (cons er (source-wrap e w s mod)) - (cdr body))))))))))))))))) - -(define chi-local-syntax - (lambda (rec? e r w s mod k) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (let ((ids (syntax (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 (syntax (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 - (chi x trans-r w mod) - mod))) - (syntax (val ...)))) - r) - new-w - s - mod)))))) - (_ (syntax-violation #f "bad local syntax definition" - (source-wrap e w s mod)))))) - -(define eval-local-transformer - (lambda (expanded mod) - (let ((p (local-eval-hook expanded mod))) - (if (procedure? p) - p - (syntax-violation #f "nonprocedure transformer" p))))) - -(define chi-void - (lambda () - (build-void no-source))) - -(define ellipsis? - (lambda (x) - (and (nonsymbol-id? x) - (free-id=? x (syntax (... ...)))))) - -(define lambda-formals - (lambda (orig-args) - (define (req args rreq) - (syntax-case args () - (() - (check (reverse rreq) #f)) - ((a . b) (id? #'a) - (req #'b (cons #'a rreq))) - (r (id? #'r) - (check (reverse rreq) #'r)) - (else - (syntax-violation 'lambda "invalid argument list" orig-args args)))) - (define (check req rest) - (cond - ((distinct-bound-ids? (if rest (cons rest req) req)) - (values req #f rest #f #f)) - (else - (syntax-violation 'lambda "duplicate identifier in argument list" - orig-args)))) - (req orig-args '()))) - -(define chi-simple-lambda - (lambda (e r w s mod req rest docstring 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 - docstring - (chi-body body (source-wrap e w s mod) - (extend-var-env labels vars r) - (make-binding-wrap ids labels w) - mod))))) - -(define lambda*-formals - (lambda (orig-args) - (define (req args rreq) - (syntax-case args () - (() - (check (reverse rreq) '() #f '() #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) #:predicate) - (pred #'b (reverse rreq) '() '())) - ((a b) (eq? (syntax->datum #'a) #:rest) - (rest #'b (reverse rreq) '() '() #f)) - (r (id? #'r) - (rest #'r (reverse rreq) '() '() #f)) - (else - (syntax-violation 'lambda* "invalid argument list" orig-args args)))) - (define (opt args req ropt) - (syntax-case args () - (() - (check req (reverse ropt) #f '() #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) #:predicate) - (pred #'b req (reverse ropt) '())) - ((a b) (eq? (syntax->datum #'a) #:rest) - (rest #'b req (reverse ropt) '() #f)) - (r (id? #'r) - (rest #'r req (reverse ropt) '() #f)) - (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)) #f)) - ((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)) #f)) - ((aok a . b) (and (eq? (syntax->datum #'aok) #:allow-other-keys) - (eq? (syntax->datum #'a) #:predicate)) - (pred #'b req opt (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)) #f)) - ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys) - (id? #'r)) - (rest #'r req opt (cons #t (reverse rkey)) #f)) - ((a . b) (eq? (syntax->datum #'a) #:predicate) - (pred #'b req opt (cons #f (reverse rkey)))) - ((a b) (eq? (syntax->datum #'a) #:rest) - (rest #'b req opt (cons #f (reverse rkey)) #f)) - (r (id? #'r) - (rest #'r req opt (cons #f (reverse rkey)) #f)) - (else - (syntax-violation 'lambda* "invalid keyword argument list" - orig-args args)))) - (define (pred args req opt kw) - (syntax-case args () - ((x) (check req opt #f kw #'x)) - ((x a b) (eq? (syntax->datum #'a) #:rest) - (rest #'b req opt kw #f)) - ((x . b) (id? #'b) - (rest #'b req opt kw #f)) - (else - (syntax-violation 'lambda* "invalid argument list following #:predicate" - orig-args args)))) - (define (rest args req opt kw pred) - (syntax-case args () - (r (id? #'r) - (check req opt #'r kw pred)) - (else - (syntax-violation 'lambda* "invalid rest argument" - orig-args args)))) - (define (check req opt rest kw pred) - (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 pred)) - (else - (syntax-violation 'lambda* "duplicate identifier in argument list" - orig-args)))) - (req orig-args '()))) - -(define chi-lambda-case - (lambda (e r w s mod get-formals clauses) - (define (expand-req req opt rest kw pred 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))) - (expand-opt (map syntax->datum req) - opt rest kw pred body (reverse vars) r* w* '() '())))) - (define (expand-opt req opt rest kw pred 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*))) - (expand-opt req (cdr opt) rest kw pred body (cons v vars) - r** w** (cons (syntax->datum #'id) out) - (cons (chi #'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*))) - (expand-kw req (if (pair? out) (reverse out) #f) - (syntax->datum rest) + (cons id ids) (cons label labels) + var-ids vars vals + (cons (make-binding 'macro (cons er (wrap e w mod))) + bindings)))) + ((begin-form) + (syntax-case e () + ((_ e1 ...) + (parse (let f ((forms #'(e1 ...))) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w mod)) + (f (cdr forms))))) + ids labels var-ids vars vals bindings)))) + ((local-syntax-form) + (chi-local-syntax value e er w s mod + (lambda (forms er w s mod) + (parse (let f ((forms forms)) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w mod)) + (f (cdr forms))))) + ids labels var-ids vars vals bindings)))) + (else ; found a non-definition + (if (null? ids) + (build-sequence no-source + (map (lambda (x) + (chi (cdr x) (car x) empty-wrap mod)) + (cons (cons er (source-wrap e w s mod)) + (cdr body)))) + (begin + (if (not (valid-bound-ids? ids)) + (syntax-violation + #f "invalid or duplicate identifier in definition" + outer-form)) + (let loop ((bs bindings) (er-cache #f) (r-cache #f)) + (if (not (null? bs)) + (let* ((b (car bs))) + (if (eq? (car b) 'macro) + (let* ((er (cadr b)) + (r-cache + (if (eq? er er-cache) + r-cache + (macros-only-env er)))) + (set-cdr! b + (eval-local-transformer + (chi (cddr b) r-cache empty-wrap mod) + mod)) + (loop (cdr bs) er r-cache)) + (loop (cdr bs) er-cache r-cache))))) + (set-cdr! r (extend-env labels bindings (cdr r))) + (build-letrec no-source + (map syntax->datum var-ids) + vars + (map (lambda (x) + (chi (cdr x) (car x) empty-wrap mod)) + vals) + (build-sequence no-source + (map (lambda (x) + (chi (cdr x) (car x) empty-wrap mod)) + (cons (cons er (source-wrap e w s mod)) + (cdr body))))))))))))))))) + + (define chi-local-syntax + (lambda (rec? e r w s mod k) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (let ((ids #'(id ...))) + (if (not (valid-bound-ids? ids)) + (syntax-violation #f "duplicate bound keyword" e) + (let ((labels (gen-labels ids))) + (let ((new-w (make-binding-wrap ids labels w))) + (k #'(e1 e2 ...) + (extend-env + labels + (let ((w (if rec? new-w w)) + (trans-r (macros-only-env r))) + (map (lambda (x) + (make-binding 'macro + (eval-local-transformer + (chi x trans-r w mod) + mod))) + #'(val ...))) + r) + new-w + s + mod)))))) + (_ (syntax-violation #f "bad local syntax definition" + (source-wrap e w s mod)))))) + + (define eval-local-transformer + (lambda (expanded mod) + (let ((p (local-eval-hook expanded mod))) + (if (procedure? p) + p + (syntax-violation #f "nonprocedure transformer" p))))) + + (define chi-void + (lambda () + (build-void no-source))) + + (define ellipsis? + (lambda (x) + (and (nonsymbol-id? x) + (free-id=? x #'(... ...))))) + + (define lambda-formals + (lambda (orig-args) + (define (req args rreq) + (syntax-case args () + (() + (check (reverse rreq) #f)) + ((a . b) (id? #'a) + (req #'b (cons #'a rreq))) + (r (id? #'r) + (check (reverse rreq) #'r)) + (else + (syntax-violation 'lambda "invalid argument list" orig-args args)))) + (define (check req rest) + (cond + ((distinct-bound-ids? (if rest (cons rest req) req)) + (values req #f rest #f #f)) + (else + (syntax-violation 'lambda "duplicate identifier in argument list" + orig-args)))) + (req orig-args '()))) + + (define chi-simple-lambda + (lambda (e r w s mod req rest docstring 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 + docstring + (chi-body body (source-wrap e w s mod) + (extend-var-env labels vars r) + (make-binding-wrap ids labels w) + mod))))) + + (define lambda*-formals + (lambda (orig-args) + (define (req args rreq) + (syntax-case args () + (() + (check (reverse rreq) '() #f '() #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) #:predicate) + (pred #'b (reverse rreq) '() '())) + ((a b) (eq? (syntax->datum #'a) #:rest) + (rest #'b (reverse rreq) '() '() #f)) + (r (id? #'r) + (rest #'r (reverse rreq) '() '() #f)) + (else + (syntax-violation 'lambda* "invalid argument list" orig-args args)))) + (define (opt args req ropt) + (syntax-case args () + (() + (check req (reverse ropt) #f '() #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) #:predicate) + (pred #'b req (reverse ropt) '())) + ((a b) (eq? (syntax->datum #'a) #:rest) + (rest #'b req (reverse ropt) '() #f)) + (r (id? #'r) + (rest #'r req (reverse ropt) '() #f)) + (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)) #f)) + ((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)) #f)) + ((aok a . b) (and (eq? (syntax->datum #'aok) #:allow-other-keys) + (eq? (syntax->datum #'a) #:predicate)) + (pred #'b req opt (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)) #f)) + ((aok . r) (and (eq? (syntax->datum #'aok) #:allow-other-keys) + (id? #'r)) + (rest #'r req opt (cons #t (reverse rkey)) #f)) + ((a . b) (eq? (syntax->datum #'a) #:predicate) + (pred #'b req opt (cons #f (reverse rkey)))) + ((a b) (eq? (syntax->datum #'a) #:rest) + (rest #'b req opt (cons #f (reverse rkey)) #f)) + (r (id? #'r) + (rest #'r req opt (cons #f (reverse rkey)) #f)) + (else + (syntax-violation 'lambda* "invalid keyword argument list" + orig-args args)))) + (define (pred args req opt kw) + (syntax-case args () + ((x) (check req opt #f kw #'x)) + ((x a b) (eq? (syntax->datum #'a) #:rest) + (rest #'b req opt kw #f)) + ((x . b) (id? #'b) + (rest #'b req opt kw #f)) + (else + (syntax-violation 'lambda* "invalid argument list following #:predicate" + orig-args args)))) + (define (rest args req opt kw pred) + (syntax-case args () + (r (id? #'r) + (check req opt #'r kw pred)) + (else + (syntax-violation 'lambda* "invalid rest argument" + orig-args args)))) + (define (check req opt rest kw pred) + (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 pred)) + (else + (syntax-violation 'lambda* "duplicate identifier in argument list" + orig-args)))) + (req orig-args '()))) + + (define chi-lambda-case + (lambda (e r w s mod get-formals clauses) + (define (expand-req req opt rest kw pred 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))) + (expand-opt (map syntax->datum req) + opt rest kw pred body (reverse vars) r* w* '() '())))) + (define (expand-opt req opt rest kw pred 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*))) + (expand-opt req (cdr opt) rest kw pred body (cons v vars) + r** w** (cons (syntax->datum #'id) out) + (cons (chi #'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*))) + (expand-kw req (if (pair? out) (reverse out) #f) + (syntax->datum rest) + (if (pair? kw) (cdr kw) kw) + pred body (cons v vars) r* w* + (if (pair? kw) (car kw) #f) + '() inits))) + (else + (expand-kw req (if (pair? out) (reverse out) #f) #f (if (pair? kw) (cdr kw) kw) - pred body (cons v vars) r* w* + pred body vars r* w* (if (pair? kw) (car kw) #f) - '() inits))) - (else - (expand-kw req (if (pair? out) (reverse out) #f) #f - (if (pair? kw) (cdr kw) kw) - pred body vars r* w* - (if (pair? kw) (car kw) #f) - '() inits)))) - (define (expand-kw req opt rest kw pred 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*))) - (expand-kw req opt rest (cdr kw) pred body (cons v vars) - r** w** aok - (cons (list (syntax->datum #'k) - (syntax->datum #'id) - v) - out) - (cons (chi #'i r* w* mod) inits)))))) - (else - (expand-pred req opt rest - (if (or aok (pair? out)) (cons aok (reverse out)) #f) - pred body (reverse vars) r* w* (reverse inits))))) - (define (expand-pred req opt rest kw pred body vars r* w* inits) - (expand-body req opt rest kw (and pred (chi pred r* w* mod)) - body vars r* w* inits)) - (define (expand-body req opt rest kw pred body vars r* w* inits) - (syntax-case body () - ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) - (values (syntax->datum #'docstring) req opt rest kw inits vars pred - (chi-body #'(e1 e2 ...) (source-wrap e w s mod) - r* w* mod))) - ((e1 e2 ...) - (values #f req opt rest kw inits vars pred - (chi-body #'(e1 e2 ...) (source-wrap e w s mod) - r* w* mod))))) - - (syntax-case clauses () - (() (values #f #f)) - (((args e1 e2 ...) (args* e1* e2* ...) ...) - (call-with-values (lambda () (get-formals #'args)) - (lambda (req opt rest kw pred) - (call-with-values (lambda () - (expand-req req opt rest kw pred #'(e1 e2 ...))) - (lambda (docstring req opt rest kw inits vars pred body) - (call-with-values - (lambda () - (chi-lambda-case e r w s mod get-formals - #'((args* e1* e2* ...) ...))) - (lambda (docstring* else*) - (values - (or docstring docstring*) - (build-lambda-case s req opt rest kw inits vars - pred body else*)))))))))))) + '() inits)))) + (define (expand-kw req opt rest kw pred 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*))) + (expand-kw req opt rest (cdr kw) pred body (cons v vars) + r** w** aok + (cons (list (syntax->datum #'k) + (syntax->datum #'id) + v) + out) + (cons (chi #'i r* w* mod) inits)))))) + (else + (expand-pred req opt rest + (if (or aok (pair? out)) (cons aok (reverse out)) #f) + pred body (reverse vars) r* w* (reverse inits))))) + (define (expand-pred req opt rest kw pred body vars r* w* inits) + (expand-body req opt rest kw (and pred (chi pred r* w* mod)) + body vars r* w* inits)) + (define (expand-body req opt rest kw pred body vars r* w* inits) + (syntax-case body () + ((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) + (values (syntax->datum #'docstring) req opt rest kw inits vars pred + (chi-body #'(e1 e2 ...) (source-wrap e w s mod) + r* w* mod))) + ((e1 e2 ...) + (values #f req opt rest kw inits vars pred + (chi-body #'(e1 e2 ...) (source-wrap e w s mod) + r* w* mod))))) + + (syntax-case clauses () + (() (values #f #f)) + (((args e1 e2 ...) (args* e1* e2* ...) ...) + (call-with-values (lambda () (get-formals #'args)) + (lambda (req opt rest kw pred) + (call-with-values (lambda () + (expand-req req opt rest kw pred #'(e1 e2 ...))) + (lambda (docstring req opt rest kw inits vars pred body) + (call-with-values + (lambda () + (chi-lambda-case e r w s mod get-formals + #'((args* e1* e2* ...) ...))) + (lambda (docstring* else*) + (values + (or docstring docstring*) + (build-lambda-case s req opt rest kw inits vars + pred body else*)))))))))))) ;;; data @@ -1803,37 +1803,37 @@ ;;; in the spine, we also check for pairs whose cars are annotated in case ;;; we've been passed the cdr of an annotated list -(define strip - (lambda (x w) - (if (top-marked? w) - x - (let f ((x x)) - (cond - ((syntax-object? x) - (strip (syntax-object-expression x) (syntax-object-wrap x))) - ((pair? x) - (let ((a (f (car x))) (d (f (cdr x)))) - (if (and (eq? a (car x)) (eq? d (cdr x))) - x - (cons a d)))) - ((vector? x) - (let ((old (vector->list x))) - (let ((new (map f old))) - (if (and-map* eq? old new) x (list->vector new))))) - (else x)))))) + (define strip + (lambda (x w) + (if (top-marked? w) + x + (let f ((x x)) + (cond + ((syntax-object? x) + (strip (syntax-object-expression x) (syntax-object-wrap x))) + ((pair? x) + (let ((a (f (car x))) (d (f (cdr x)))) + (if (and (eq? a (car x)) (eq? d (cdr x))) + x + (cons a d)))) + ((vector? x) + (let ((old (vector->list x))) + (let ((new (map f old))) + (if (and-map* eq? old new) x (list->vector new))))) + (else x)))))) ;;; lexical variables -(define gen-var - (lambda (id) - (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (build-lexical-var no-source id)))) + (define gen-var + (lambda (id) + (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) + (build-lexical-var no-source id)))) -;; appears to return a reversed list -(define lambda-var-list - (lambda (vars) - (let lvl ((vars vars) (ls '()) (w empty-wrap)) - (cond + ;; appears to return a reversed list + (define lambda-var-list + (lambda (vars) + (let lvl ((vars vars) (ls '()) (w empty-wrap)) + (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) ((id? vars) (cons (wrap vars w #f) ls)) ((null? vars) ls) @@ -1841,541 +1841,541 @@ (lvl (syntax-object-expression vars) ls (join-wraps w (syntax-object-wrap vars)))) - ; include anything else to be caught by subsequent error - ; checking + ; include anything else to be caught by subsequent error + ; checking (else (cons vars ls)))))) ;;; core transformers -(global-extend 'local-syntax 'letrec-syntax #t) -(global-extend 'local-syntax 'let-syntax #f) - -(global-extend 'core 'fluid-let-syntax - (lambda (e r w s mod) - (syntax-case e () - ((_ ((var val) ...) e1 e2 ...) - (valid-bound-ids? (syntax (var ...))) - (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...))))) - (for-each - (lambda (id n) - (case (binding-type (lookup n r mod)) - ((displaced-lexical) - (syntax-violation 'fluid-let-syntax - "identifier out of context" - e - (source-wrap id w s mod))))) - (syntax (var ...)) - names) - (chi-body - (syntax (e1 e2 ...)) - (source-wrap e w s mod) - (extend-env - names - (let ((trans-r (macros-only-env r))) - (map (lambda (x) - (make-binding 'macro - (eval-local-transformer (chi x trans-r w mod) - mod))) - (syntax (val ...)))) - r) - w - mod))) - (_ (syntax-violation 'fluid-let-syntax "bad syntax" - (source-wrap e w s mod)))))) - -(global-extend 'core 'quote - (lambda (e r w s mod) - (syntax-case e () - ((_ e) (build-data s (strip (syntax e) w))) - (_ (syntax-violation 'quote "bad syntax" - (source-wrap e w s mod)))))) + (global-extend 'local-syntax 'letrec-syntax #t) + (global-extend 'local-syntax 'let-syntax #f) + + (global-extend 'core 'fluid-let-syntax + (lambda (e r w s mod) + (syntax-case e () + ((_ ((var val) ...) e1 e2 ...) + (valid-bound-ids? #'(var ...)) + (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...)))) + (for-each + (lambda (id n) + (case (binding-type (lookup n r mod)) + ((displaced-lexical) + (syntax-violation 'fluid-let-syntax + "identifier out of context" + e + (source-wrap id w s mod))))) + #'(var ...) + names) + (chi-body + #'(e1 e2 ...) + (source-wrap e w s mod) + (extend-env + names + (let ((trans-r (macros-only-env r))) + (map (lambda (x) + (make-binding 'macro + (eval-local-transformer (chi x trans-r w mod) + mod))) + #'(val ...))) + r) + w + mod))) + (_ (syntax-violation 'fluid-let-syntax "bad syntax" + (source-wrap e w s mod)))))) + + (global-extend 'core 'quote + (lambda (e r w s mod) + (syntax-case e () + ((_ e) (build-data s (strip #'e w))) + (_ (syntax-violation 'quote "bad syntax" + (source-wrap e w s mod)))))) + + (global-extend 'core 'syntax + (let () + (define gen-syntax + (lambda (src e r maps ellipsis? mod) + (if (id? e) + (let ((label (id-var-name e empty-wrap))) + (let ((b (lookup label r mod))) + (if (eq? (binding-type b) 'syntax) + (call-with-values + (lambda () + (let ((var.lev (binding-value b))) + (gen-ref src (car var.lev) (cdr var.lev) maps))) + (lambda (var maps) (values `(ref ,var) maps))) + (if (ellipsis? e) + (syntax-violation 'syntax "misplaced ellipsis" src) + (values `(quote ,e) maps))))) + (syntax-case e () + ((dots e) + (ellipsis? #'dots) + (gen-syntax src #'e r maps (lambda (x) #f) mod)) + ((x dots . y) + ; this could be about a dozen lines of code, except that we + ; choose to handle #'(x ... ...) forms + (ellipsis? #'dots) + (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) + (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)))) + (_ (values `(quote ,e) maps)))))) + + (define gen-ref + (lambda (src var level maps) + (if (fx= level 0) + (values var maps) + (if (null? maps) + (syntax-violation 'syntax "missing ellipsis" src) + (call-with-values + (lambda () (gen-ref src var (fx- level 1) (cdr maps))) + (lambda (outer-var outer-maps) + (let ((b (assq outer-var (car maps)))) + (if b + (values (cdr b) maps) + (let ((inner-var (gen-var 'tmp))) + (values inner-var + (cons (cons (cons outer-var inner-var) + (car maps)) + outer-maps))))))))))) + + (define gen-mappend + (lambda (e map-env) + `(apply (primitive append) ,(gen-map e map-env)))) + + (define gen-map + (lambda (e map-env) + (let ((formals (map cdr map-env)) + (actuals (map (lambda (x) `(ref ,(car x))) map-env))) + (cond + ((eq? (car e) 'ref) + ; identity map equivalence: + ; (map (lambda (x) x) y) == y + (car actuals)) + ((and-map + (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) + (cdr e)) + ; eta map equivalence: + ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) + `(map (primitive ,(car e)) + ,@(map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e)))) + (else `(map (lambda ,formals ,e) ,@actuals)))))) + + (define gen-cons + (lambda (x y) + (case (car y) + ((quote) + (if (eq? (car x) 'quote) + `(quote (,(cadr x) . ,(cadr y))) + (if (eq? (cadr y) '()) + `(list ,x) + `(cons ,x ,y)))) + ((list) `(list ,x ,@(cdr y))) + (else `(cons ,x ,y))))) + + (define gen-append + (lambda (x y) + (if (equal? y '(quote ())) + x + `(append ,x ,y)))) + + (define gen-vector + (lambda (x) + (cond + ((eq? (car x) 'list) `(vector ,@(cdr x))) + ((eq? (car x) 'quote) `(quote #(,@(cadr x)))) + (else `(list->vector ,x))))) -(global-extend 'core 'syntax - (let () - (define gen-syntax - (lambda (src e r maps ellipsis? mod) - (if (id? e) - (let ((label (id-var-name e empty-wrap))) - (let ((b (lookup label r mod))) - (if (eq? (binding-type b) 'syntax) - (call-with-values - (lambda () - (let ((var.lev (binding-value b))) - (gen-ref src (car var.lev) (cdr var.lev) maps))) - (lambda (var maps) (values `(ref ,var) maps))) - (if (ellipsis? e) - (syntax-violation 'syntax "misplaced ellipsis" src) - (values `(quote ,e) maps))))) - (syntax-case e () - ((dots e) - (ellipsis? (syntax dots)) - (gen-syntax src (syntax e) r maps (lambda (x) #f) mod)) - ((x dots . y) - ; this could be about a dozen lines of code, except that we - ; choose to handle (syntax (x ... ...)) forms - (ellipsis? (syntax dots)) - (let f ((y (syntax y)) - (k (lambda (maps) - (call-with-values - (lambda () - (gen-syntax src (syntax 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? (syntax dots)) - (f (syntax 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) + + (define regen + (lambda (x) + (case (car x) + ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) + ((primitive) (build-primref no-source (cadr x))) + ((quote) (build-data no-source (cadr x))) + ((lambda) + (if (list? (cadr x)) + (build-simple-lambda no-source (cadr x) #f (cadr x) #f (regen (caddr x))) + (error "how did we get here" x))) + (else (build-application no-source + (build-primref 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 () (k maps)) - (lambda (x maps) - (values (gen-append x y) maps))))))))) - ((x . y) - (call-with-values - (lambda () (gen-syntax src (syntax x) r maps ellipsis? mod)) - (lambda (x maps) - (call-with-values - (lambda () (gen-syntax src (syntax y) r maps ellipsis? mod)) - (lambda (y maps) (values (gen-cons x y) maps)))))) - (#(e1 e2 ...) - (call-with-values - (lambda () - (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis? mod)) - (lambda (e maps) (values (gen-vector e) maps)))) - (_ (values `(quote ,e) maps)))))) - - (define gen-ref - (lambda (src var level maps) - (if (fx= level 0) - (values var maps) - (if (null? maps) - (syntax-violation 'syntax "missing ellipsis" src) - (call-with-values - (lambda () (gen-ref src var (fx- level 1) (cdr maps))) - (lambda (outer-var outer-maps) - (let ((b (assq outer-var (car maps)))) - (if b - (values (cdr b) maps) - (let ((inner-var (gen-var 'tmp))) - (values inner-var - (cons (cons (cons outer-var inner-var) - (car maps)) - outer-maps))))))))))) - - (define gen-mappend - (lambda (e map-env) - `(apply (primitive append) ,(gen-map e map-env)))) - - (define gen-map - (lambda (e map-env) - (let ((formals (map cdr map-env)) - (actuals (map (lambda (x) `(ref ,(car x))) map-env))) - (cond - ((eq? (car e) 'ref) - ; identity map equivalence: - ; (map (lambda (x) x) y) == y - (car actuals)) - ((and-map - (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) - (cdr e)) - ; eta map equivalence: - ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) - `(map (primitive ,(car e)) - ,@(map (let ((r (map cons formals actuals))) - (lambda (x) (cdr (assq (cadr x) r)))) - (cdr e)))) - (else `(map (lambda ,formals ,e) ,@actuals)))))) - - (define gen-cons - (lambda (x y) - (case (car y) - ((quote) - (if (eq? (car x) 'quote) - `(quote (,(cadr x) . ,(cadr y))) - (if (eq? (cadr y) '()) - `(list ,x) - `(cons ,x ,y)))) - ((list) `(list ,x ,@(cdr y))) - (else `(cons ,x ,y))))) - - (define gen-append - (lambda (x y) - (if (equal? y '(quote ())) - x - `(append ,x ,y)))) - - (define gen-vector - (lambda (x) - (cond - ((eq? (car x) 'list) `(vector ,@(cdr x))) - ((eq? (car x) 'quote) `(quote #(,@(cadr x)))) - (else `(list->vector ,x))))) - - - (define regen - (lambda (x) - (case (car x) - ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x))) - ((primitive) (build-primref no-source (cadr x))) - ((quote) (build-data no-source (cadr x))) - ((lambda) - (if (list? (cadr x)) - (build-simple-lambda no-source (cadr x) #f (cadr x) #f (regen (caddr x))) - (error "how did we get here" x))) - (else (build-application no-source - (build-primref 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 (syntax x) r '() ellipsis? mod)) - (lambda (e maps) (regen e)))) - (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) - -(global-extend 'core 'lambda - (lambda (e r w s mod) - (syntax-case e () - ((_ args docstring e1 e2 ...) (string? (syntax->datum #'docstring)) - (call-with-values (lambda () (lambda-formals #'args)) - (lambda (req opt rest kw pred) - (chi-simple-lambda e r w s mod req rest (syntax->datum #'docstring) - #'(e1 e2 ...))))) - ((_ args e1 e2 ...) - (call-with-values (lambda () (lambda-formals #'args)) - (lambda (req opt rest kw pred) - (chi-simple-lambda e r w s mod req rest #f #'(e1 e2 ...))))) - (_ (syntax-violation 'lambda "bad lambda" e))))) - -(global-extend 'core 'lambda* - (lambda (e r w s mod) - (syntax-case e () - ((_ args e1 e2 ...) - (call-with-values - (lambda () - (chi-lambda-case e r w s mod - lambda*-formals #'((args e1 e2 ...)))) - (lambda (docstring lcase) - (build-case-lambda s docstring lcase)))) - (_ (syntax-violation 'lambda "bad lambda*" e))))) - -(global-extend 'core 'case-lambda - (lambda (e r w s mod) - (syntax-case e () - ((_ (args e1 e2 ...) (args* e1* e2* ...) ...) - (call-with-values - (lambda () - (chi-lambda-case e r w s mod - lambda-formals - #'((args e1 e2 ...) (args* e1* e2* ...) ...))) - (lambda (docstring lcase) - (build-case-lambda s docstring lcase)))) - (_ (syntax-violation 'case-lambda "bad case-lambda" e))))) - -(global-extend 'core 'case-lambda* - (lambda (e r w s mod) - (syntax-case e () - ((_ (args e1 e2 ...) (args* e1* e2* ...) ...) - (call-with-values - (lambda () - (chi-lambda-case e r w s mod - lambda*-formals - #'((args e1 e2 ...) (args* e1* e2* ...) ...))) - (lambda (docstring lcase) - (build-case-lambda s docstring lcase)))) - (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) - -(global-extend 'core 'let - (let () - (define (chi-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) (chi x r w mod)) vals) - (chi-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? (syntax (id ...))) - (chi-let e r w s mod - build-let - (syntax (id ...)) - (syntax (val ...)) - (syntax (e1 e2 ...)))) - ((_ f ((id val) ...) e1 e2 ...) - (and (id? (syntax f)) (and-map id? (syntax (id ...)))) - (chi-let e r w s mod - build-named-let - (syntax (f id ...)) - (syntax (val ...)) - (syntax (e1 e2 ...)))) - (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) - - -(global-extend 'core 'letrec - (lambda (e r w s mod) - (syntax-case e () - ((_ ((id val) ...) e1 e2 ...) - (and-map id? (syntax (id ...))) - (let ((ids (syntax (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 - (map syntax->datum ids) - new-vars - (map (lambda (x) (chi x r w mod)) (syntax (val ...))) - (chi-body (syntax (e1 e2 ...)) - (source-wrap e w s mod) r w mod))))))) - (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) - - -(global-extend 'core 'set! - (lambda (e r w s mod) - (syntax-case e () - ((_ id val) - (id? (syntax id)) - (let ((val (chi (syntax val) r w mod)) - (n (id-var-name (syntax id) w))) - (let ((b (lookup n r mod))) - (case (binding-type b) - ((lexical) - (build-lexical-assignment s - (syntax->datum (syntax id)) - (binding-value b) - val)) - ((global) (build-global-assignment s n val mod)) - ((displaced-lexical) - (syntax-violation 'set! "identifier out of context" - (wrap (syntax id) w mod))) - (else (syntax-violation 'set! "bad set!" - (source-wrap e w s mod))))))) - ((_ (head tail ...) val) - (call-with-values - (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod #t)) - (lambda (type value ee ww ss modmod) - (case type - ((module-ref) - (let ((val (chi (syntax val) r w mod))) - (call-with-values (lambda () (value (syntax (head tail ...)))) - (lambda (id mod) - (build-global-assignment s id val mod))))) - (else - (build-application s - (chi (syntax (setter head)) r w mod) - (map (lambda (e) (chi e r w mod)) - (syntax (tail ... val))))))))) - (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) - -(global-extend 'module-ref '@ - (lambda (e) - (syntax-case e () - ((_ (mod ...) id) - (and (and-map id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax->datum (syntax id)) - (syntax->datum - (syntax (public mod ...)))))))) - -(global-extend 'module-ref '@@ - (lambda (e) - (syntax-case e () - ((_ (mod ...) id) - (and (and-map id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax->datum (syntax id)) - (syntax->datum - (syntax (private mod ...)))))))) - -(global-extend 'core 'if - (lambda (e r w s mod) - (syntax-case e () - ((_ test then) - (build-conditional - s - (chi (syntax test) r w mod) - (chi (syntax then) r w mod) - (build-void no-source))) - ((_ test then else) - (build-conditional - s - (chi (syntax test) r w mod) - (chi (syntax then) r w mod) - (chi (syntax else) r w mod)))))) - -(global-extend 'begin 'begin '()) - -(global-extend 'define 'define '()) - -(global-extend 'define-syntax 'define-syntax '()) - -(global-extend 'eval-when 'eval-when '()) - -(global-extend 'core 'syntax-case - (let () - (define convert-pattern - ; accepts pattern & keys - ; returns $sc-dispatch pattern & ids - (lambda (pattern keys) - (let cvt ((p pattern) (n 0) (ids '())) - (if (id? p) - (if (bound-id-member? p keys) - (values (vector 'free-id p) ids) - (values 'any (cons (cons p n) ids))) - (syntax-case p () - ((x dots) - (ellipsis? (syntax dots)) - (call-with-values - (lambda () (cvt (syntax x) (fx+ n 1) ids)) - (lambda (p ids) - (values (if (eq? p 'any) 'each-any (vector 'each p)) - 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 empty-wrap)) ids))))))) - - (define build-dispatch-call - (lambda (pvars exp y r mod) - (let ((ids (map car pvars)) (levels (map cdr pvars))) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-application no-source - (build-primref no-source 'apply) - (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars #f - (chi exp - (extend-env - labels - (map (lambda (var level) - (make-binding 'syntax `(,var . ,level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels empty-wrap) - mod)) - y)))))) - - (define gen-clause - (lambda (x keys clauses r pat fender exp mod) - (call-with-values - (lambda () (convert-pattern pat keys)) - (lambda (p pvars) - (cond - ((not (distinct-bound-ids? (map car pvars))) - (syntax-violation 'syntax-case "duplicate pattern variable" pat)) - ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars)) - (syntax-violation 'syntax-case "misplaced ellipsis" pat)) - (else - (let ((y (gen-var 'tmp))) - ; fat finger binding and references to temp variable y - (build-application no-source - (build-simple-lambda no-source (list 'tmp) #f (list y) #f - (let ((y (build-lexical-reference 'value no-source - 'tmp y))) - (build-conditional no-source - (syntax-case fender () - (#t y) - (_ (build-conditional no-source - y - (build-dispatch-call pvars fender y r mod) - (build-data no-source #f)))) - (build-dispatch-call pvars exp y r mod) - (gen-syntax-case x keys clauses r mod)))) - (list (if (eq? p 'any) - (build-application no-source - (build-primref no-source 'list) - (list x)) - (build-application no-source - (build-primref no-source '$sc-dispatch) - (list x (build-data no-source p))))))))))))) - - (define gen-syntax-case - (lambda (x keys clauses r mod) - (if (null? clauses) - (build-application no-source - (build-primref 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? (syntax pat)) - (and-map (lambda (x) (not (free-id=? (syntax pat) x))) - (cons (syntax (... ...)) keys))) - (let ((labels (list (gen-label))) - (var (gen-var (syntax pat)))) - (build-application no-source - (build-simple-lambda - no-source (list (syntax->datum (syntax pat))) #f (list var) - #f - (chi (syntax exp) - (extend-env labels - (list (make-binding 'syntax `(,var . 0))) - r) - (make-binding-wrap (syntax (pat)) - labels empty-wrap) - mod)) - (list x))) - (gen-clause x keys (cdr clauses) r - (syntax pat) #t (syntax exp) mod))) - ((pat fender exp) - (gen-clause x keys (cdr clauses) r - (syntax pat) (syntax fender) (syntax 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)))) - (syntax (key ...))) - (let ((x (gen-var 'tmp))) - ; fat finger binding and references to temp variable x - (build-application s - (build-simple-lambda no-source (list 'tmp) #f (list x) #f - (gen-syntax-case (build-lexical-reference 'value no-source - 'tmp x) - (syntax (key ...)) (syntax (m ...)) - r - mod)) - (list (chi (syntax val) r empty-wrap mod)))) - (syntax-violation 'syntax-case "invalid literals list" e)))))))) + (lambda () (gen-syntax e #'x r '() ellipsis? mod)) + (lambda (e maps) (regen e)))) + (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) + + (global-extend 'core 'lambda + (lambda (e r w s mod) + (syntax-case e () + ((_ args docstring e1 e2 ...) (string? (syntax->datum #'docstring)) + (call-with-values (lambda () (lambda-formals #'args)) + (lambda (req opt rest kw pred) + (chi-simple-lambda e r w s mod req rest (syntax->datum #'docstring) + #'(e1 e2 ...))))) + ((_ args e1 e2 ...) + (call-with-values (lambda () (lambda-formals #'args)) + (lambda (req opt rest kw pred) + (chi-simple-lambda e r w s mod req rest #f #'(e1 e2 ...))))) + (_ (syntax-violation 'lambda "bad lambda" e))))) + + (global-extend 'core 'lambda* + (lambda (e r w s mod) + (syntax-case e () + ((_ args e1 e2 ...) + (call-with-values + (lambda () + (chi-lambda-case e r w s mod + lambda*-formals #'((args e1 e2 ...)))) + (lambda (docstring lcase) + (build-case-lambda s docstring lcase)))) + (_ (syntax-violation 'lambda "bad lambda*" e))))) + + (global-extend 'core 'case-lambda + (lambda (e r w s mod) + (syntax-case e () + ((_ (args e1 e2 ...) (args* e1* e2* ...) ...) + (call-with-values + (lambda () + (chi-lambda-case e r w s mod + lambda-formals + #'((args e1 e2 ...) (args* e1* e2* ...) ...))) + (lambda (docstring lcase) + (build-case-lambda s docstring lcase)))) + (_ (syntax-violation 'case-lambda "bad case-lambda" e))))) + + (global-extend 'core 'case-lambda* + (lambda (e r w s mod) + (syntax-case e () + ((_ (args e1 e2 ...) (args* e1* e2* ...) ...) + (call-with-values + (lambda () + (chi-lambda-case e r w s mod + lambda*-formals + #'((args e1 e2 ...) (args* e1* e2* ...) ...))) + (lambda (docstring lcase) + (build-case-lambda s docstring lcase)))) + (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) + + (global-extend 'core 'let + (let () + (define (chi-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) (chi x r w mod)) vals) + (chi-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 ...)) + (chi-let e r w s mod + build-let + #'(id ...) + #'(val ...) + #'(e1 e2 ...))) + ((_ f ((id val) ...) e1 e2 ...) + (and (id? #'f) (and-map id? #'(id ...))) + (chi-let e r w s mod + build-named-let + #'(f id ...) + #'(val ...) + #'(e1 e2 ...))) + (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) + + + (global-extend 'core 'letrec + (lambda (e r w s mod) + (syntax-case e () + ((_ ((id val) ...) e1 e2 ...) + (and-map id? #'(id ...)) + (let ((ids #'(id ...))) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec "duplicate bound variable" e) + (let ((labels (gen-labels ids)) + (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec s + (map syntax->datum ids) + new-vars + (map (lambda (x) (chi x r w mod)) #'(val ...)) + (chi-body #'(e1 e2 ...) + (source-wrap e w s mod) r w mod))))))) + (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) + + + (global-extend 'core 'set! + (lambda (e r w s mod) + (syntax-case e () + ((_ id val) + (id? #'id) + (let ((val (chi #'val r w mod)) + (n (id-var-name #'id w))) + (let ((b (lookup n r mod))) + (case (binding-type b) + ((lexical) + (build-lexical-assignment s + (syntax->datum #'id) + (binding-value b) + val)) + ((global) (build-global-assignment s n val 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 ww ss modmod) + (case type + ((module-ref) + (let ((val (chi #'val r w mod))) + (call-with-values (lambda () (value #'(head tail ...))) + (lambda (id mod) + (build-global-assignment s id val mod))))) + (else + (build-application s + (chi #'(setter head) r w mod) + (map (lambda (e) (chi e r w mod)) + #'(tail ... val)))))))) + (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) + + (global-extend 'module-ref '@ + (lambda (e) + (syntax-case e () + ((_ (mod ...) id) + (and (and-map id? #'(mod ...)) (id? #'id)) + (values (syntax->datum #'id) + (syntax->datum + #'(public mod ...))))))) + + (global-extend 'module-ref '@@ + (lambda (e) + (syntax-case e () + ((_ (mod ...) id) + (and (and-map id? #'(mod ...)) (id? #'id)) + (values (syntax->datum #'id) + (syntax->datum + #'(private mod ...))))))) + + (global-extend 'core 'if + (lambda (e r w s mod) + (syntax-case e () + ((_ test then) + (build-conditional + s + (chi #'test r w mod) + (chi #'then r w mod) + (build-void no-source))) + ((_ test then else) + (build-conditional + s + (chi #'test r w mod) + (chi #'then r w mod) + (chi #'else r w mod)))))) + + (global-extend 'begin 'begin '()) + + (global-extend 'define 'define '()) + + (global-extend 'define-syntax 'define-syntax '()) + + (global-extend 'eval-when 'eval-when '()) + + (global-extend 'core 'syntax-case + (let () + (define convert-pattern + ; accepts pattern & keys + ; returns $sc-dispatch pattern & ids + (lambda (pattern keys) + (let cvt ((p pattern) (n 0) (ids '())) + (if (id? p) + (if (bound-id-member? p keys) + (values (vector 'free-id p) ids) + (values 'any (cons (cons p n) ids))) + (syntax-case p () + ((x dots) + (ellipsis? #'dots) + (call-with-values + (lambda () (cvt #'x (fx+ n 1) ids)) + (lambda (p ids) + (values (if (eq? p 'any) 'each-any (vector 'each p)) + ids)))) + ((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)))))) + (() (values '() ids)) + (#(x ...) + (call-with-values + (lambda () (cvt #'(x ...) n ids)) + (lambda (p ids) (values (vector 'vector p) ids)))) + (x (values (vector 'atom (strip p empty-wrap)) ids))))))) + + (define build-dispatch-call + (lambda (pvars exp y r mod) + (let ((ids (map car pvars)) (levels (map cdr pvars))) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (build-application no-source + (build-primref no-source 'apply) + (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars #f + (chi exp + (extend-env + labels + (map (lambda (var level) + (make-binding 'syntax `(,var . ,level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels empty-wrap) + mod)) + y)))))) + + (define gen-clause + (lambda (x keys clauses r pat fender exp mod) + (call-with-values + (lambda () (convert-pattern pat keys)) + (lambda (p pvars) + (cond + ((not (distinct-bound-ids? (map car pvars))) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) + (else + (let ((y (gen-var 'tmp))) + ; fat finger binding and references to temp variable y + (build-application no-source + (build-simple-lambda no-source (list 'tmp) #f (list y) #f + (let ((y (build-lexical-reference 'value no-source + 'tmp y))) + (build-conditional no-source + (syntax-case fender () + (#t y) + (_ (build-conditional no-source + y + (build-dispatch-call pvars fender y r mod) + (build-data no-source #f)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) + (list (if (eq? p 'any) + (build-application no-source + (build-primref no-source 'list) + (list x)) + (build-application no-source + (build-primref no-source '$sc-dispatch) + (list x (build-data no-source p))))))))))))) + + (define gen-syntax-case + (lambda (x keys clauses r mod) + (if (null? clauses) + (build-application no-source + (build-primref 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))) + (let ((labels (list (gen-label))) + (var (gen-var #'pat))) + (build-application no-source + (build-simple-lambda + no-source (list (syntax->datum #'pat)) #f (list var) + #f + (chi #'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)))) + #'(key ...)) + (let ((x (gen-var 'tmp))) + ; fat finger binding and references to temp variable x + (build-application s + (build-simple-lambda no-source (list 'tmp) #f (list x) #f + (gen-syntax-case (build-lexical-reference 'value no-source + 'tmp x) + #'(key ...) #'(m ...) + r + mod)) + (list (chi #'val r empty-wrap mod)))) + (syntax-violation 'syntax-case "invalid literals list" e)))))))) ;;; The portable sc-expand seeds chi-top's mode m with 'e (for ;;; evaluating) and esew (which stands for "eval syntax expanders @@ -2386,65 +2386,65 @@ ;;; syntactic definitions are evaluated immediately after they are ;;; expanded, and the expanded definitions are also residualized into ;;; the object file if we are compiling a file. -(set! sc-expand - (lambda (x . rest) - (if (and (pair? x) (equal? (car x) noexpand)) - (cadr x) - (let ((m (if (null? rest) 'e (car rest))) - (esew (if (or (null? rest) (null? (cdr rest))) - '(eval) - (cadr rest)))) - (with-fluid* *mode* m - (lambda () - (chi-top x null-env top-wrap m esew - (cons 'hygiene (module-name (current-module)))))))))) - -(set! identifier? - (lambda (x) - (nonsymbol-id? x))) + (set! sc-expand + (lambda (x . rest) + (if (and (pair? x) (equal? (car x) noexpand)) + (cadr x) + (let ((m (if (null? rest) 'e (car rest))) + (esew (if (or (null? rest) (null? (cdr rest))) + '(eval) + (cadr rest)))) + (with-fluid* *mode* m + (lambda () + (chi-top x null-env top-wrap m esew + (cons 'hygiene (module-name (current-module)))))))))) + + (set! identifier? + (lambda (x) + (nonsymbol-id? x))) -(set! datum->syntax - (lambda (id datum) - (make-syntax-object datum (syntax-object-wrap id) #f))) + (set! datum->syntax + (lambda (id datum) + (make-syntax-object datum (syntax-object-wrap id) #f))) -(set! syntax->datum - ; accepts any object, since syntax objects may consist partially - ; or entirely of unwrapped, nonsymbolic data - (lambda (x) - (strip x empty-wrap))) - -(set! generate-temporaries - (lambda (ls) - (arg-check list? ls 'generate-temporaries) - (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls))) - -(set! free-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'free-identifier=?) - (arg-check nonsymbol-id? y 'free-identifier=?) - (free-id=? x y))) - -(set! bound-identifier=? - (lambda (x y) - (arg-check nonsymbol-id? x 'bound-identifier=?) - (arg-check nonsymbol-id? y 'bound-identifier=?) - (bound-id=? x y))) - -(set! syntax-violation - (lambda (who message form . subform) - (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) - who 'syntax-violation) - (arg-check string? message 'syntax-violation) - (scm-error 'syntax-error 'sc-expand - (string-append - (if who "~a: " "") - "~a " - (if (null? subform) "in ~a" "in subform `~s' of `~s'")) - (let ((tail (cons message - (map (lambda (x) (strip x empty-wrap)) - (append subform (list form)))))) - (if who (cons who tail) tail)) - #f))) + (set! syntax->datum + ; accepts any object, since syntax objects may consist partially + ; or entirely of unwrapped, nonsymbolic data + (lambda (x) + (strip x empty-wrap))) + + (set! generate-temporaries + (lambda (ls) + (arg-check list? ls 'generate-temporaries) + (map (lambda (x) (wrap (gensym-hook) top-wrap #f)) ls))) + + (set! free-identifier=? + (lambda (x y) + (arg-check nonsymbol-id? x 'free-identifier=?) + (arg-check nonsymbol-id? y 'free-identifier=?) + (free-id=? x y))) + + (set! bound-identifier=? + (lambda (x y) + (arg-check nonsymbol-id? x 'bound-identifier=?) + (arg-check nonsymbol-id? y 'bound-identifier=?) + (bound-id=? x y))) + + (set! syntax-violation + (lambda (who message form . subform) + (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) + who 'syntax-violation) + (arg-check string? message 'syntax-violation) + (scm-error 'syntax-error 'sc-expand + (string-append + (if who "~a: " "") + "~a " + (if (null? subform) "in ~a" "in subform `~s' of `~s'")) + (let ((tail (cons message + (map (lambda (x) (strip x empty-wrap)) + (append subform (list form)))))) + (if who (cons who tail) tail)) + #f))) ;;; $sc-dispatch expects an expression and a pattern. If the expression ;;; matches the pattern a list of the matching expressions for each @@ -2468,134 +2468,134 @@ ;;; not, should convert to: ;;; #(vector <pattern>*) #(<pattern>*) -(let () + (let () -(define match-each - (lambda (e p w mod) - (cond - ((pair? e) - (let ((first (match (car e) p w '() mod))) - (and first - (let ((rest (match-each (cdr e) p w mod))) - (and rest (cons first rest)))))) - ((null? e) '()) - ((syntax-object? e) - (match-each (syntax-object-expression e) - p - (join-wraps w (syntax-object-wrap e)) - (syntax-object-module e))) - (else #f)))) - -(define match-each-any - (lambda (e w mod) - (cond - ((pair? e) - (let ((l (match-each-any (cdr e) w mod))) - (and l (cons (wrap (car e) w mod) l)))) - ((null? e) '()) - ((syntax-object? e) - (match-each-any (syntax-object-expression e) + (define match-each + (lambda (e p w mod) + (cond + ((pair? e) + (let ((first (match (car e) p w '() mod))) + (and first + (let ((rest (match-each (cdr e) p w mod))) + (and rest (cons first rest)))))) + ((null? e) '()) + ((syntax-object? e) + (match-each (syntax-object-expression e) + p (join-wraps w (syntax-object-wrap e)) - mod)) - (else #f)))) + (syntax-object-module e))) + (else #f)))) -(define match-empty - (lambda (p r) - (cond - ((null? 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)) - ((free-id atom) r) - ((vector) (match-empty (vector-ref p 1) r))))))) - -(define match* - (lambda (e p w r mod) - (cond - ((null? p) (and (null? e) r)) - ((pair? p) - (and (pair? e) (match (car e) (car p) w - (match (cdr e) (cdr p) w r mod) - mod))) - ((eq? p 'each-any) - (let ((l (match-each-any e w mod))) (and l (cons l r)))) - (else - (case (vector-ref p 0) - ((each) - (if (null? e) - (match-empty (vector-ref p 1) r) - (let ((l (match-each e (vector-ref p 1) w mod))) - (and l - (let collect ((l l)) - (if (null? (car l)) - r - (cons (map car l) (collect (map cdr l))))))))) - ((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 w)) r)) - ((vector) - (and (vector? e) - (match (vector->list e) (vector-ref p 1) w r mod)))))))) - -(define match - (lambda (e p w r mod) - (cond - ((not r) #f) - ((eq? p 'any) (cons (wrap e w mod) r)) - ((syntax-object? e) - (match* - (syntax-object-expression e) - p - (join-wraps w (syntax-object-wrap e)) - r - (syntax-object-module e))) - (else (match* e p w r mod))))) - -(set! $sc-dispatch - (lambda (e p) - (cond - ((eq? p 'any) (list e)) - ((syntax-object? e) - (match* (syntax-object-expression e) - p (syntax-object-wrap e) '() (syntax-object-module e))) - (else (match* e p empty-wrap '() #f))))) + (define match-each-any + (lambda (e w mod) + (cond + ((pair? e) + (let ((l (match-each-any (cdr e) w mod))) + (and l (cons (wrap (car e) w mod) l)))) + ((null? e) '()) + ((syntax-object? e) + (match-each-any (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)) + mod)) + (else #f)))) + + (define match-empty + (lambda (p r) + (cond + ((null? 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)) + ((free-id atom) r) + ((vector) (match-empty (vector-ref p 1) r))))))) + + (define match* + (lambda (e p w r mod) + (cond + ((null? p) (and (null? e) r)) + ((pair? p) + (and (pair? e) (match (car e) (car p) w + (match (cdr e) (cdr p) w r mod) + mod))) + ((eq? p 'each-any) + (let ((l (match-each-any e w mod))) (and l (cons l r)))) + (else + (case (vector-ref p 0) + ((each) + (if (null? e) + (match-empty (vector-ref p 1) r) + (let ((l (match-each e (vector-ref p 1) w mod))) + (and l + (let collect ((l l)) + (if (null? (car l)) + r + (cons (map car l) (collect (map cdr l))))))))) + ((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 w)) r)) + ((vector) + (and (vector? e) + (match (vector->list e) (vector-ref p 1) w r mod)))))))) + + (define match + (lambda (e p w r mod) + (cond + ((not r) #f) + ((eq? p 'any) (cons (wrap e w mod) r)) + ((syntax-object? e) + (match* + (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + r + (syntax-object-module e))) + (else (match* e p w r mod))))) + + (set! $sc-dispatch + (lambda (e p) + (cond + ((eq? p 'any) (list e)) + ((syntax-object? e) + (match* (syntax-object-expression e) + p (syntax-object-wrap e) '() (syntax-object-module e))) + (else (match* e p empty-wrap '() #f))))) -)) + )) ) (define-syntax with-syntax (lambda (x) (syntax-case x () ((_ () e1 e2 ...) - (syntax (begin e1 e2 ...))) + #'(begin e1 e2 ...)) ((_ ((out in)) e1 e2 ...) - (syntax (syntax-case in () (out (begin e1 e2 ...))))) + #'(syntax-case in () (out (begin e1 e2 ...)))) ((_ ((out in) ...) e1 e2 ...) - (syntax (syntax-case (list in ...) () - ((out ...) (begin e1 e2 ...)))))))) + #'(syntax-case (list in ...) () + ((out ...) (begin e1 e2 ...))))))) (define-syntax syntax-rules (lambda (x) (syntax-case x () ((_ (k ...) ((keyword . pattern) template) ...) - (syntax (lambda (x) - (syntax-case x (k ...) - ((dummy . pattern) (syntax template)) - ...))))))) + #'(lambda (x) + (syntax-case x (k ...) + ((dummy . pattern) #'template) + ...)))))) (define-syntax let* (lambda (x) (syntax-case x () ((let* ((x v) ...) e1 e2 ...) - (and-map identifier? (syntax (x ...))) - (let f ((bindings (syntax ((x v) ...)))) + (and-map identifier? #'(x ...)) + (let f ((bindings #'((x v) ...))) (if (null? bindings) - (syntax (let () e1 e2 ...)) + #'(let () e1 e2 ...) (with-syntax ((body (f (cdr bindings))) (binding (car bindings))) - (syntax (let (binding) body))))))))) + #'(let (binding) body)))))))) (define-syntax do (lambda (orig-x) @@ -2603,85 +2603,85 @@ ((_ ((var init . step) ...) (e0 e1 ...) c ...) (with-syntax (((step ...) (map (lambda (v s) - (syntax-case s () - (() v) - ((e) (syntax e)) - (_ (syntax-violation - 'do "bad step expression" - orig-x s)))) - (syntax (var ...)) - (syntax (step ...))))) - (syntax-case (syntax (e1 ...)) () - (() (syntax (let doloop ((var init) ...) - (if (not e0) - (begin c ... (doloop step ...)))))) - ((e1 e2 ...) - (syntax (let doloop ((var init) ...) - (if e0 - (begin e1 e2 ...) - (begin c ... (doloop step ...)))))))))))) + (syntax-case s () + (() v) + ((e) #'e) + (_ (syntax-violation + 'do "bad step expression" + orig-x s)))) + #'(var ...) + #'(step ...)))) + (syntax-case #'(e1 ...) () + (() #'(let doloop ((var init) ...) + (if (not e0) + (begin c ... (doloop step ...))))) + ((e1 e2 ...) + #'(let doloop ((var init) ...) + (if e0 + (begin e1 e2 ...) + (begin c ... (doloop step ...))))))))))) (define-syntax quasiquote (letrec ((quasicons (lambda (x y) (with-syntax ((x x) (y y)) - (syntax-case (syntax y) (quote list) + (syntax-case #'y (quote list) ((quote dy) - (syntax-case (syntax x) (quote) - ((quote dx) (syntax (quote (dx . dy)))) - (_ (if (null? (syntax dy)) - (syntax (list x)) - (syntax (cons x y)))))) - ((list . stuff) (syntax (list x . stuff))) - (else (syntax (cons x y))))))) + (syntax-case #'x (quote) + ((quote dx) #'(quote (dx . dy))) + (_ (if (null? #'dy) + #'(list x) + #'(cons x y))))) + ((list . stuff) #'(list x . stuff)) + (else #'(cons x y)))))) (quasiappend (lambda (x y) (with-syntax ((x x) (y y)) - (syntax-case (syntax y) (quote) - ((quote ()) (syntax x)) - (_ (syntax (append x y))))))) + (syntax-case #'y (quote) + ((quote ()) #'x) + (_ #'(append x y)))))) (quasivector (lambda (x) (with-syntax ((x x)) - (syntax-case (syntax x) (quote list) - ((quote (x ...)) (syntax (quote #(x ...)))) - ((list x ...) (syntax (vector x ...))) - (_ (syntax (list->vector x))))))) + (syntax-case #'x (quote list) + ((quote (x ...)) #'(quote #(x ...))) + ((list x ...) #'(vector x ...)) + (_ #'(list->vector x)))))) (quasi (lambda (p lev) (syntax-case p (unquote unquote-splicing quasiquote) ((unquote p) (if (= lev 0) - (syntax p) - (quasicons (syntax (quote unquote)) - (quasi (syntax (p)) (- lev 1))))) + #'p + (quasicons #'(quote unquote) + (quasi #'(p) (- lev 1))))) ((unquote . args) (= lev 0) (syntax-violation 'unquote "unquote takes exactly one argument" - p (syntax (unquote . args)))) + p #'(unquote . args))) (((unquote-splicing p) . q) (if (= lev 0) - (quasiappend (syntax p) (quasi (syntax q) lev)) - (quasicons (quasicons (syntax (quote unquote-splicing)) - (quasi (syntax (p)) (- lev 1))) - (quasi (syntax q) lev)))) + (quasiappend #'p (quasi #'q lev)) + (quasicons (quasicons #'(quote unquote-splicing) + (quasi #'(p) (- lev 1))) + (quasi #'q lev)))) (((unquote-splicing . args) . q) (= lev 0) (syntax-violation 'unquote-splicing "unquote-splicing takes exactly one argument" - p (syntax (unquote-splicing . args)))) + p #'(unquote-splicing . args))) ((quasiquote p) - (quasicons (syntax (quote quasiquote)) - (quasi (syntax (p)) (+ lev 1)))) + (quasicons #'(quote quasiquote) + (quasi #'(p) (+ lev 1)))) ((p . q) - (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev))) - (#(x ...) (quasivector (quasi (syntax (x ...)) lev))) - (p (syntax (quote p))))))) + (quasicons (quasi #'p lev) (quasi #'q lev))) + (#(x ...) (quasivector (quasi #'(x ...) lev))) + (p #'(quote p)))))) (lambda (x) (syntax-case x () - ((_ e) (quasi (syntax e) 0)))))) + ((_ e) (quasi #'e 0)))))) (define-syntax include (lambda (x) @@ -2695,9 +2695,9 @@ (f (read p)))))))) (syntax-case x () ((k filename) - (let ((fn (syntax->datum (syntax filename)))) - (with-syntax (((exp ...) (read-file fn (syntax k)))) - (syntax (begin exp ...)))))))) + (let ((fn (syntax->datum #'filename))) + (with-syntax (((exp ...) (read-file fn #'k))) + #'(begin exp ...))))))) (define-syntax unquote (lambda (x) @@ -2720,35 +2720,34 @@ (syntax-case x () ((_ e m1 m2 ...) (with-syntax - ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...)))) - (if (null? clauses) - (syntax-case clause (else) - ((else e1 e2 ...) (syntax (begin e1 e2 ...))) - (((k ...) e1 e2 ...) - (syntax (if (memv t '(k ...)) (begin e1 e2 ...)))) - (_ (syntax-violation 'case "bad clause" x clause))) - (with-syntax ((rest (f (car clauses) (cdr clauses)))) + ((body (let f ((clause #'m1) (clauses #'(m2 ...))) + (if (null? clauses) (syntax-case clause (else) + ((else e1 e2 ...) #'(begin e1 e2 ...)) (((k ...) e1 e2 ...) - (syntax (if (memv t '(k ...)) - (begin e1 e2 ...) - rest))) - (_ (syntax-violation 'case "bad clause" x - clause)))))))) - (syntax (let ((t e)) body))))))) + #'(if (memv t '(k ...)) (begin e1 e2 ...))) + (_ (syntax-violation 'case "bad clause" x clause))) + (with-syntax ((rest (f (car clauses) (cdr clauses)))) + (syntax-case clause (else) + (((k ...) e1 e2 ...) + #'(if (memv t '(k ...)) + (begin e1 e2 ...) + rest)) + (_ (syntax-violation 'case "bad clause" x + clause)))))))) + #'(let ((t e)) body)))))) (define-syntax identifier-syntax (lambda (x) (syntax-case x () ((_ e) - (syntax - (lambda (x) + #'(lambda (x) (syntax-case x () (id - (identifier? (syntax id)) - (syntax e)) + (identifier? #'id) + #'e) ((_ x (... ...)) - (syntax (e x (... ...))))))))))) + #'(e x (... ...))))))))) (define-syntax define* (syntax-rules () |