diff options
author | Andy Wingo <wingo@pobox.com> | 2017-03-27 20:38:55 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-03-28 19:23:13 +0200 |
commit | eb84c2f2da83cf04214bbacf4b33528ce09a5b1a (patch) | |
tree | 18d022910aaa92e869e54a45261d495f16267595 | |
parent | 64c5cc58fced3092f17639bbbddb46c1bae974c8 (diff) | |
download | guile-eb84c2f2da83cf04214bbacf4b33528ce09a5b1a.tar.gz |
Beginnings of psyntax switch to new syntax objects
* module/ice-9/psyntax.scm: Baby steps towards support of a new
representation of syntax objects.
* module/ice-9/psyntax-pp.scm: Regenerate.
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 5228 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 27 |
2 files changed, 2642 insertions, 2613 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 7749e3cd6..a26545aa6 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,2639 +1,2647 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec* - ((make-void - (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src))) - (make-const - (lambda (src exp) - (make-struct (vector-ref %expanded-vtables 1) 0 src exp))) - (make-primitive-ref - (lambda (src name) - (make-struct (vector-ref %expanded-vtables 2) 0 src name))) - (make-lexical-ref - (lambda (src name gensym) - (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym))) - (make-lexical-set - (lambda (src name gensym exp) - (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp))) - (make-module-ref - (lambda (src mod name public?) - (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?))) - (make-module-set - (lambda (src mod name public? exp) - (make-struct - (vector-ref %expanded-vtables 6) - 0 - src - mod - name - public? - exp))) - (make-toplevel-ref - (lambda (src name) - (make-struct (vector-ref %expanded-vtables 7) 0 src name))) - (make-toplevel-set - (lambda (src name exp) - (make-struct (vector-ref %expanded-vtables 8) 0 src name exp))) - (make-toplevel-define - (lambda (src name exp) - (make-struct (vector-ref %expanded-vtables 9) 0 src name exp))) - (make-conditional - (lambda (src test consequent alternate) - (make-struct - (vector-ref %expanded-vtables 10) - 0 - src - test - consequent - alternate))) - (make-call - (lambda (src proc args) - (make-struct (vector-ref %expanded-vtables 11) 0 src proc args))) - (make-primcall - (lambda (src name args) - (make-struct (vector-ref %expanded-vtables 12) 0 src name args))) - (make-seq - (lambda (src head tail) - (make-struct (vector-ref %expanded-vtables 13) 0 src head tail))) - (make-lambda - (lambda (src meta body) - (make-struct (vector-ref %expanded-vtables 14) 0 src meta body))) - (make-lambda-case - (lambda (src req opt rest kw inits gensyms body alternate) - (make-struct - (vector-ref %expanded-vtables 15) - 0 - src - req - opt - rest - kw - inits - gensyms - body - alternate))) - (make-let - (lambda (src names gensyms vals body) - (make-struct - (vector-ref %expanded-vtables 16) - 0 - src - names - gensyms - vals - body))) - (make-letrec - (lambda (src in-order? names gensyms vals body) - (make-struct - (vector-ref %expanded-vtables 17) - 0 - src - in-order? - names - gensyms - vals - body))) - (lambda? - (lambda (x) - (and (struct? x) - (eq? (struct-vtable x) (vector-ref %expanded-vtables 14))))) - (lambda-meta (lambda (x) (struct-ref x 1))) - (set-lambda-meta! (lambda (x v) (struct-set! x 1 v))) - (top-level-eval-hook (lambda (x mod) (primitive-eval x))) - (local-eval-hook (lambda (x mod) (primitive-eval x))) - (session-id - (let ((v (module-variable (current-module) 'syntax-session-id))) - (lambda () ((variable-ref v))))) - (put-global-definition-hook - (lambda (symbol type val) - (module-define! - (current-module) - symbol - (make-syntax-transformer symbol type val)))) - (get-global-definition-hook - (lambda (symbol module) - (if (and (not module) (current-module)) - (warn "module system is booted, we should have a module" symbol)) - (and (not (equal? module '(primitive))) - (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) - (macro-type val) - (cons (macro-type val) (macro-binding val))))))))) - (decorate-source - (lambda (e s) - (if (and s (supports-source-properties? e)) - (set-source-properties! e s)) - e)) - (maybe-name-value! - (lambda (name val) - (if (lambda? val) - (let ((meta (lambda-meta val))) - (if (not (assq 'name meta)) - (set-lambda-meta! val (acons 'name name meta))))))) - (build-void (lambda (source) (make-void source))) - (build-call - (lambda (source fun-exp arg-exps) - (make-call source fun-exp arg-exps))) - (build-conditional - (lambda (source test-exp then-exp else-exp) - (make-conditional source test-exp then-exp else-exp))) - (build-lexical-reference - (lambda (type source name var) (make-lexical-ref source name var))) - (build-lexical-assignment - (lambda (source name var exp) - (maybe-name-value! name exp) - (make-lexical-set source name var exp))) - (analyze-variable - (lambda (mod var modref-cont bare-cont) - (if (not mod) - (bare-cont var) - (let ((kind (car mod)) (mod (cdr mod))) - (let ((key kind)) - (cond ((memv key '(public)) (modref-cont mod var #t)) - ((memv key '(private)) - (if (not (equal? mod (module-name (current-module)))) - (modref-cont mod var #f) - (bare-cont var))) - ((memv key '(bare)) (bare-cont var)) - ((memv key '(hygiene)) - (if (and (not (equal? mod (module-name (current-module)))) - (module-variable (resolve-module mod) var)) - (modref-cont mod var #f) - (bare-cont var))) - ((memv key '(primitive)) - (syntax-violation #f "primitive not in operator position" var)) - (else (syntax-violation #f "bad module kind" var mod)))))))) - (build-global-reference - (lambda (source var mod) - (analyze-variable - mod - var - (lambda (mod var public?) (make-module-ref source mod var public?)) - (lambda (var) (make-toplevel-ref source var))))) - (build-global-assignment - (lambda (source var exp mod) - (maybe-name-value! var exp) - (analyze-variable - mod - var - (lambda (mod var public?) - (make-module-set source mod var public? exp)) - (lambda (var) (make-toplevel-set source var exp))))) - (build-global-definition - (lambda (source var exp) - (maybe-name-value! var exp) - (make-toplevel-define source var exp))) - (build-simple-lambda - (lambda (src req rest vars meta exp) - (make-lambda - src - meta - (make-lambda-case src req #f rest #f '() vars exp #f)))) - (build-case-lambda - (lambda (src meta body) (make-lambda src meta body))) - (build-lambda-case - (lambda (src req opt rest kw inits vars body else-case) - (make-lambda-case src req opt rest kw inits vars body else-case))) - (build-primcall - (lambda (src name args) (make-primcall src name args))) - (build-primref (lambda (src name) (make-primitive-ref src name))) - (build-data (lambda (src exp) (make-const src exp))) - (build-sequence - (lambda (src exps) - (if (null? (cdr exps)) - (car exps) - (make-seq src (car exps) (build-sequence #f (cdr exps)))))) - (build-let - (lambda (src ids vars val-exps body-exp) - (for-each maybe-name-value! ids val-exps) - (if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))) - (build-named-let - (lambda (src ids vars val-exps body-exp) - (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) - (let ((proc (build-simple-lambda src ids #f vars '() body-exp))) - (maybe-name-value! f-name proc) - (for-each maybe-name-value! ids val-exps) - (make-letrec - src - #f - (list f-name) - (list f) - (list proc) - (build-call src (build-lexical-reference 'fun src f-name f) val-exps)))))) - (build-letrec - (lambda (src in-order? ids vars val-exps body-exp) - (if (null? vars) - body-exp - (begin - (for-each maybe-name-value! ids val-exps) - (make-letrec src in-order? ids vars val-exps body-exp))))) - (make-syntax-object - (lambda (expression wrap module) - (vector 'syntax-object expression wrap module))) - (syntax-object? - (lambda (x) - (and (vector? x) - (= (vector-length x) 4) - (eq? (vector-ref x 0) 'syntax-object)))) - (syntax-object-expression (lambda (x) (vector-ref x 1))) - (syntax-object-wrap (lambda (x) (vector-ref x 2))) - (syntax-object-module (lambda (x) (vector-ref x 3))) - (set-syntax-object-expression! - (lambda (x update) (vector-set! x 1 update))) - (set-syntax-object-wrap! - (lambda (x update) (vector-set! x 2 update))) - (set-syntax-object-module! - (lambda (x update) (vector-set! x 3 update))) - (source-annotation - (lambda (x) - (let ((props (source-properties - (if (syntax-object? x) (syntax-object-expression x) x)))) - (and (pair? props) props)))) - (extend-env - (lambda (labels bindings r) - (if (null? labels) - r - (extend-env - (cdr labels) - (cdr bindings) - (cons (cons (car labels) (car bindings)) r))))) - (extend-var-env - (lambda (labels vars r) - (if (null? labels) - r - (extend-var-env - (cdr labels) - (cdr vars) - (cons (cons (car labels) (cons 'lexical (car vars))) r))))) - (macros-only-env - (lambda (r) - (if (null? r) - '() - (let ((a (car r))) - (if (memq (cadr a) '(macro syntax-parameter ellipsis)) - (cons a (macros-only-env (cdr r))) - (macros-only-env (cdr r))))))) - (global-extend - (lambda (type sym val) (put-global-definition-hook sym type val))) - (nonsymbol-id? - (lambda (x) - (and (syntax-object? x) (symbol? (syntax-object-expression x))))) - (id? (lambda (x) - (if (symbol? x) - #t - (and (syntax-object? x) (symbol? (syntax-object-expression x)))))) - (id-sym-name&marks - (lambda (x w) - (if (syntax-object? x) - (values - (syntax-object-expression x) - (join-marks (car w) (car (syntax-object-wrap x)))) - (values x (car w))))) - (gen-label (lambda () (symbol->string (module-gensym "l")))) - (gen-labels - (lambda (ls) - (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) - (make-ribcage - (lambda (symnames marks labels) - (vector 'ribcage symnames marks labels))) - (ribcage? - (lambda (x) - (and (vector? x) - (= (vector-length x) 4) - (eq? (vector-ref x 0) 'ribcage)))) - (ribcage-symnames (lambda (x) (vector-ref x 1))) - (ribcage-marks (lambda (x) (vector-ref x 2))) - (ribcage-labels (lambda (x) (vector-ref x 3))) - (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update))) - (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update))) - (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update))) - (anti-mark - (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w))))) - (extend-ribcage! - (lambda (ribcage id label) - (set-ribcage-symnames! - ribcage - (cons (syntax-object-expression id) (ribcage-symnames ribcage))) - (set-ribcage-marks! - ribcage - (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage))) - (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage))))) - (make-binding-wrap - (lambda (ids labels w) - (if (null? ids) - w - (cons (car w) - (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec))) - (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) - (let f ((ids ids) (i 0)) - (if (not (null? ids)) - (call-with-values - (lambda () (id-sym-name&marks (car ids) w)) - (lambda (symname marks) - (vector-set! symnamevec i symname) - (vector-set! marksvec i marks) - (f (cdr ids) (+ i 1)))))) - (make-ribcage symnamevec marksvec labelvec))) - (cdr w)))))) - (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2)))) - (join-wraps - (lambda (w1 w2) - (let ((m1 (car w1)) (s1 (cdr w1))) - (if (null? m1) - (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2)))) - (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2))))))) - (join-marks (lambda (m1 m2) (smart-append m1 m2))) - (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)))))) - (id-var-name - (lambda (id w mod) - (letrec* - ((search - (lambda (sym subst marks mod) - (if (null? subst) - (values #f marks) - (let ((fst (car subst))) - (if (eq? fst 'shift) - (search sym (cdr subst) (cdr marks) mod) - (let ((symnames (ribcage-symnames fst))) - (if (vector? symnames) - (search-vector-rib sym subst marks symnames fst mod) - (search-list-rib sym subst marks symnames fst mod)))))))) - (search-list-rib - (lambda (sym subst marks symnames ribcage mod) - (let f ((symnames symnames) (i 0)) - (cond ((null? symnames) (search sym (cdr subst) marks mod)) - ((and (eq? (car symnames) sym) - (same-marks? marks (list-ref (ribcage-marks ribcage) i))) - (let ((n (list-ref (ribcage-labels ribcage) i))) - (if (pair? n) - (if (equal? mod (car n)) - (values (cdr n) marks) - (f (cdr symnames) (+ i 1))) - (values n marks)))) - (else (f (cdr symnames) (+ i 1))))))) - (search-vector-rib - (lambda (sym subst marks symnames ribcage mod) - (let ((n (vector-length symnames))) - (let f ((i 0)) - (cond ((= i n) (search sym (cdr subst) marks mod)) - ((and (eq? (vector-ref symnames i) sym) - (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) - (let ((n (vector-ref (ribcage-labels ribcage) i))) +(let ((syntax? (module-ref (current-module) 'syntax?)) + (make-syntax (module-ref (current-module) 'make-syntax)) + (syntax-expression (module-ref (current-module) 'syntax-expression)) + (syntax-wrap (module-ref (current-module) 'syntax-wrap)) + (syntax-module (module-ref (current-module) 'syntax-module))) + (letrec* + ((make-void + (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src))) + (make-const + (lambda (src exp) + (make-struct (vector-ref %expanded-vtables 1) 0 src exp))) + (make-primitive-ref + (lambda (src name) + (make-struct (vector-ref %expanded-vtables 2) 0 src name))) + (make-lexical-ref + (lambda (src name gensym) + (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym))) + (make-lexical-set + (lambda (src name gensym exp) + (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp))) + (make-module-ref + (lambda (src mod name public?) + (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?))) + (make-module-set + (lambda (src mod name public? exp) + (make-struct + (vector-ref %expanded-vtables 6) + 0 + src + mod + name + public? + exp))) + (make-toplevel-ref + (lambda (src name) + (make-struct (vector-ref %expanded-vtables 7) 0 src name))) + (make-toplevel-set + (lambda (src name exp) + (make-struct (vector-ref %expanded-vtables 8) 0 src name exp))) + (make-toplevel-define + (lambda (src name exp) + (make-struct (vector-ref %expanded-vtables 9) 0 src name exp))) + (make-conditional + (lambda (src test consequent alternate) + (make-struct + (vector-ref %expanded-vtables 10) + 0 + src + test + consequent + alternate))) + (make-call + (lambda (src proc args) + (make-struct (vector-ref %expanded-vtables 11) 0 src proc args))) + (make-primcall + (lambda (src name args) + (make-struct (vector-ref %expanded-vtables 12) 0 src name args))) + (make-seq + (lambda (src head tail) + (make-struct (vector-ref %expanded-vtables 13) 0 src head tail))) + (make-lambda + (lambda (src meta body) + (make-struct (vector-ref %expanded-vtables 14) 0 src meta body))) + (make-lambda-case + (lambda (src req opt rest kw inits gensyms body alternate) + (make-struct + (vector-ref %expanded-vtables 15) + 0 + src + req + opt + rest + kw + inits + gensyms + body + alternate))) + (make-let + (lambda (src names gensyms vals body) + (make-struct + (vector-ref %expanded-vtables 16) + 0 + src + names + gensyms + vals + body))) + (make-letrec + (lambda (src in-order? names gensyms vals body) + (make-struct + (vector-ref %expanded-vtables 17) + 0 + src + in-order? + names + gensyms + vals + body))) + (lambda? + (lambda (x) + (and (struct? x) + (eq? (struct-vtable x) (vector-ref %expanded-vtables 14))))) + (lambda-meta (lambda (x) (struct-ref x 1))) + (set-lambda-meta! (lambda (x v) (struct-set! x 1 v))) + (top-level-eval-hook (lambda (x mod) (primitive-eval x))) + (local-eval-hook (lambda (x mod) (primitive-eval x))) + (session-id + (let ((v (module-variable (current-module) 'syntax-session-id))) + (lambda () ((variable-ref v))))) + (put-global-definition-hook + (lambda (symbol type val) + (module-define! + (current-module) + symbol + (make-syntax-transformer symbol type val)))) + (get-global-definition-hook + (lambda (symbol module) + (if (and (not module) (current-module)) + (warn "module system is booted, we should have a module" symbol)) + (and (not (equal? module '(primitive))) + (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) + (macro-type val) + (cons (macro-type val) (macro-binding val))))))))) + (decorate-source + (lambda (e s) + (if (and s (supports-source-properties? e)) + (set-source-properties! e s)) + e)) + (maybe-name-value! + (lambda (name val) + (if (lambda? val) + (let ((meta (lambda-meta val))) + (if (not (assq 'name meta)) + (set-lambda-meta! val (acons 'name name meta))))))) + (build-void (lambda (source) (make-void source))) + (build-call + (lambda (source fun-exp arg-exps) + (make-call source fun-exp arg-exps))) + (build-conditional + (lambda (source test-exp then-exp else-exp) + (make-conditional source test-exp then-exp else-exp))) + (build-lexical-reference + (lambda (type source name var) (make-lexical-ref source name var))) + (build-lexical-assignment + (lambda (source name var exp) + (maybe-name-value! name exp) + (make-lexical-set source name var exp))) + (analyze-variable + (lambda (mod var modref-cont bare-cont) + (if (not mod) + (bare-cont var) + (let ((kind (car mod)) (mod (cdr mod))) + (let ((key kind)) + (cond ((memv key '(public)) (modref-cont mod var #t)) + ((memv key '(private)) + (if (not (equal? mod (module-name (current-module)))) + (modref-cont mod var #f) + (bare-cont var))) + ((memv key '(bare)) (bare-cont var)) + ((memv key '(hygiene)) + (if (and (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + (modref-cont mod var #f) + (bare-cont var))) + ((memv key '(primitive)) + (syntax-violation #f "primitive not in operator position" var)) + (else (syntax-violation #f "bad module kind" var mod)))))))) + (build-global-reference + (lambda (source var mod) + (analyze-variable + mod + var + (lambda (mod var public?) (make-module-ref source mod var public?)) + (lambda (var) (make-toplevel-ref source var))))) + (build-global-assignment + (lambda (source var exp mod) + (maybe-name-value! var exp) + (analyze-variable + mod + var + (lambda (mod var public?) + (make-module-set source mod var public? exp)) + (lambda (var) (make-toplevel-set source var exp))))) + (build-global-definition + (lambda (source var exp) + (maybe-name-value! var exp) + (make-toplevel-define source var exp))) + (build-simple-lambda + (lambda (src req rest vars meta exp) + (make-lambda + src + meta + (make-lambda-case src req #f rest #f '() vars exp #f)))) + (build-case-lambda + (lambda (src meta body) (make-lambda src meta body))) + (build-lambda-case + (lambda (src req opt rest kw inits vars body else-case) + (make-lambda-case src req opt rest kw inits vars body else-case))) + (build-primcall + (lambda (src name args) (make-primcall src name args))) + (build-primref (lambda (src name) (make-primitive-ref src name))) + (build-data (lambda (src exp) (make-const src exp))) + (build-sequence + (lambda (src exps) + (if (null? (cdr exps)) + (car exps) + (make-seq src (car exps) (build-sequence #f (cdr exps)))))) + (build-let + (lambda (src ids vars val-exps body-exp) + (for-each maybe-name-value! ids val-exps) + (if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))) + (build-named-let + (lambda (src ids vars val-exps body-exp) + (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) + (let ((proc (build-simple-lambda src ids #f vars '() body-exp))) + (maybe-name-value! f-name proc) + (for-each maybe-name-value! ids val-exps) + (make-letrec + src + #f + (list f-name) + (list f) + (list proc) + (build-call src (build-lexical-reference 'fun src f-name f) val-exps)))))) + (build-letrec + (lambda (src in-order? ids vars val-exps body-exp) + (if (null? vars) + body-exp + (begin + (for-each maybe-name-value! ids val-exps) + (make-letrec src in-order? ids vars val-exps body-exp))))) + (syntax-object? + (lambda (x) + (or (syntax? x) + (and (vector? x) + (= (vector-length x) 4) + (eqv? (vector-ref x 0) 'syntax-object))))) + (make-syntax-object + (lambda (expression wrap module) + (vector 'syntax-object expression wrap module))) + (syntax-object-expression + (lambda (obj) + (if (syntax? obj) (syntax-expression obj) (vector-ref obj 1)))) + (syntax-object-wrap + (lambda (obj) + (if (syntax? obj) (syntax-wrap obj) (vector-ref obj 2)))) + (syntax-object-module + (lambda (obj) + (if (syntax? obj) (syntax-module obj) (vector-ref obj 3)))) + (source-annotation + (lambda (x) + (let ((props (source-properties + (if (syntax-object? x) (syntax-object-expression x) x)))) + (and (pair? props) props)))) + (extend-env + (lambda (labels bindings r) + (if (null? labels) + r + (extend-env + (cdr labels) + (cdr bindings) + (cons (cons (car labels) (car bindings)) r))))) + (extend-var-env + (lambda (labels vars r) + (if (null? labels) + r + (extend-var-env + (cdr labels) + (cdr vars) + (cons (cons (car labels) (cons 'lexical (car vars))) r))))) + (macros-only-env + (lambda (r) + (if (null? r) + '() + (let ((a (car r))) + (if (memq (cadr a) '(macro syntax-parameter ellipsis)) + (cons a (macros-only-env (cdr r))) + (macros-only-env (cdr r))))))) + (global-extend + (lambda (type sym val) (put-global-definition-hook sym type val))) + (nonsymbol-id? + (lambda (x) + (and (syntax-object? x) (symbol? (syntax-object-expression x))))) + (id? (lambda (x) + (if (symbol? x) + #t + (and (syntax-object? x) (symbol? (syntax-object-expression x)))))) + (id-sym-name&marks + (lambda (x w) + (if (syntax-object? x) + (values + (syntax-object-expression x) + (join-marks (car w) (car (syntax-object-wrap x)))) + (values x (car w))))) + (gen-label (lambda () (symbol->string (module-gensym "l")))) + (gen-labels + (lambda (ls) + (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) + (make-ribcage + (lambda (symnames marks labels) + (vector 'ribcage symnames marks labels))) + (ribcage? + (lambda (x) + (and (vector? x) + (= (vector-length x) 4) + (eq? (vector-ref x 0) 'ribcage)))) + (ribcage-symnames (lambda (x) (vector-ref x 1))) + (ribcage-marks (lambda (x) (vector-ref x 2))) + (ribcage-labels (lambda (x) (vector-ref x 3))) + (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update))) + (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update))) + (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update))) + (anti-mark + (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w))))) + (extend-ribcage! + (lambda (ribcage id label) + (set-ribcage-symnames! + ribcage + (cons (syntax-object-expression id) (ribcage-symnames ribcage))) + (set-ribcage-marks! + ribcage + (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage))) + (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage))))) + (make-binding-wrap + (lambda (ids labels w) + (if (null? ids) + w + (cons (car w) + (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec))) + (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) + (let f ((ids ids) (i 0)) + (if (not (null? ids)) + (call-with-values + (lambda () (id-sym-name&marks (car ids) w)) + (lambda (symname marks) + (vector-set! symnamevec i symname) + (vector-set! marksvec i marks) + (f (cdr ids) (+ i 1)))))) + (make-ribcage symnamevec marksvec labelvec))) + (cdr w)))))) + (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2)))) + (join-wraps + (lambda (w1 w2) + (let ((m1 (car w1)) (s1 (cdr w1))) + (if (null? m1) + (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2)))) + (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2))))))) + (join-marks (lambda (m1 m2) (smart-append m1 m2))) + (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)))))) + (id-var-name + (lambda (id w mod) + (letrec* + ((search + (lambda (sym subst marks mod) + (if (null? subst) + (values #f marks) + (let ((fst (car subst))) + (if (eq? fst 'shift) + (search sym (cdr subst) (cdr marks) mod) + (let ((symnames (ribcage-symnames fst))) + (if (vector? symnames) + (search-vector-rib sym subst marks symnames fst mod) + (search-list-rib sym subst marks symnames fst mod)))))))) + (search-list-rib + (lambda (sym subst marks symnames ribcage mod) + (let f ((symnames symnames) (i 0)) + (cond ((null? symnames) (search sym (cdr subst) marks mod)) + ((and (eq? (car symnames) sym) + (same-marks? marks (list-ref (ribcage-marks ribcage) i))) + (let ((n (list-ref (ribcage-labels ribcage) i))) (if (pair? n) - (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1))) + (if (equal? mod (car n)) + (values (cdr n) marks) + (f (cdr symnames) (+ i 1))) (values n marks)))) - (else (f (+ i 1))))))))) - (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id)) - ((syntax-object? id) - (let ((id (syntax-object-expression id)) - (w1 (syntax-object-wrap id)) - (mod (syntax-object-module id))) - (let ((marks (join-marks (car w) (car w1)))) - (call-with-values - (lambda () (search id (cdr w) marks mod)) - (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id)))))) - (else (syntax-violation 'id-var-name "invalid id" id)))))) - (locally-bound-identifiers - (lambda (w mod) - (letrec* - ((scan (lambda (subst results) - (if (null? subst) - results - (let ((fst (car subst))) - (if (eq? fst 'shift) - (scan (cdr subst) results) - (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst))) - (if (vector? symnames) - (scan-vector-rib subst symnames marks results) - (scan-list-rib subst symnames marks results)))))))) - (scan-list-rib - (lambda (subst symnames marks results) - (let f ((symnames symnames) (marks marks) (results results)) - (if (null? symnames) - (scan (cdr subst) results) - (f (cdr symnames) - (cdr marks) - (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod) - results)))))) - (scan-vector-rib - (lambda (subst symnames marks results) - (let ((n (vector-length symnames))) - (let f ((i 0) (results results)) - (if (= i n) - (scan (cdr subst) results) - (f (+ i 1) - (cons (wrap (vector-ref symnames i) - (anti-mark (cons (vector-ref marks i) subst)) - mod) - results)))))))) - (scan (cdr w) '())))) - (resolve-identifier - (lambda (id w r mod resolve-syntax-parameters?) - (letrec* - ((resolve-syntax-parameters - (lambda (b) - (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter)) - (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b)))) - b))) - (resolve-global - (lambda (var mod) - (let ((b (resolve-syntax-parameters - (or (get-global-definition-hook var mod) '(global))))) - (if (eq? (car b) 'global) - (values 'global var mod) - (values (car b) (cdr b) mod))))) - (resolve-lexical - (lambda (label mod) - (let ((b (resolve-syntax-parameters - (or (assq-ref r label) '(displaced-lexical))))) - (values (car b) (cdr b) mod))))) - (let ((n (id-var-name id w mod))) - (cond ((syntax-object? n) - (if (not (eq? n id)) - (resolve-identifier n w r mod resolve-syntax-parameters?) - (resolve-identifier - (syntax-object-expression n) - (syntax-object-wrap n) - r - (syntax-object-module n) - resolve-syntax-parameters?))) - ((symbol? n) - (resolve-global - n - (if (syntax-object? id) (syntax-object-module id) mod))) - ((string? n) - (resolve-lexical - n - (if (syntax-object? id) (syntax-object-module id) mod))) - (else (error "unexpected id-var-name" id w n))))))) - (transformer-environment - (make-fluid - (lambda (k) - (error "called outside the dynamic extent of a syntax transformer")))) - (with-transformer-environment - (lambda (k) ((fluid-ref transformer-environment) k))) - (free-id=? - (lambda (i j) - (let* ((mi (and (syntax-object? i) (syntax-object-module i))) - (mj (and (syntax-object? j) (syntax-object-module j))) - (ni (id-var-name i '(()) mi)) - (nj (id-var-name j '(()) mj))) + (else (f (cdr symnames) (+ i 1))))))) + (search-vector-rib + (lambda (sym subst marks symnames ribcage mod) + (let ((n (vector-length symnames))) + (let f ((i 0)) + (cond ((= i n) (search sym (cdr subst) marks mod)) + ((and (eq? (vector-ref symnames i) sym) + (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) + (let ((n (vector-ref (ribcage-labels ribcage) i))) + (if (pair? n) + (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1))) + (values n marks)))) + (else (f (+ i 1))))))))) + (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id)) + ((syntax-object? id) + (let ((id (syntax-object-expression id)) + (w1 (syntax-object-wrap id)) + (mod (syntax-object-module id))) + (let ((marks (join-marks (car w) (car w1)))) + (call-with-values + (lambda () (search id (cdr w) marks mod)) + (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id)))))) + (else (syntax-violation 'id-var-name "invalid id" id)))))) + (locally-bound-identifiers + (lambda (w mod) (letrec* - ((id-module-binding - (lambda (id mod) - (module-variable - (if mod (resolve-module (cdr mod)) (current-module)) - (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x)))))) - (cond ((syntax-object? ni) (free-id=? ni j)) - ((syntax-object? nj) (free-id=? i nj)) - ((symbol? ni) - (and (eq? nj - (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x))) - (let ((bi (id-module-binding i mi))) - (if bi - (eq? bi (id-module-binding j mj)) - (and (not (id-module-binding j mj)) (eq? ni nj)))) - (eq? (id-module-binding i mi) (id-module-binding j mj)))) - (else (equal? ni nj))))))) - (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? - (car (syntax-object-wrap i)) - (car (syntax-object-wrap j)))) - (eq? i j)))) - (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? - (lambda (ids) - (let distinct? ((ids ids)) - (or (null? ids) - (and (not (bound-id-member? (car ids) (cdr ids))) - (distinct? (cdr ids))))))) - (bound-id-member? - (lambda (x list) - (and (not (null? list)) - (or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) - (wrap (lambda (x w defmod) - (cond ((and (null? (car w)) (null? (cdr 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))))) - (source-wrap - (lambda (x w s defmod) (wrap (decorate-source x s) w defmod))) - (expand-sequence - (lambda (body r w s mod) - (build-sequence - s - (let dobody ((body body) (r r) (w w) (mod mod)) - (if (null? body) - '() - (let ((first (expand (car body) r w mod))) - (cons first (dobody (cdr body) r w mod)))))))) - (expand-top-sequence - (lambda (body r w s m esew mod) - (let* ((r (cons '("placeholder" placeholder) r)) - (ribcage (make-ribcage '() '() '())) - (w (cons (car w) (cons ribcage (cdr w))))) + ((scan (lambda (subst results) + (if (null? subst) + results + (let ((fst (car subst))) + (if (eq? fst 'shift) + (scan (cdr subst) results) + (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst))) + (if (vector? symnames) + (scan-vector-rib subst symnames marks results) + (scan-list-rib subst symnames marks results)))))))) + (scan-list-rib + (lambda (subst symnames marks results) + (let f ((symnames symnames) (marks marks) (results results)) + (if (null? symnames) + (scan (cdr subst) results) + (f (cdr symnames) + (cdr marks) + (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod) + results)))))) + (scan-vector-rib + (lambda (subst symnames marks results) + (let ((n (vector-length symnames))) + (let f ((i 0) (results results)) + (if (= i n) + (scan (cdr subst) results) + (f (+ i 1) + (cons (wrap (vector-ref symnames i) + (anti-mark (cons (vector-ref marks i) subst)) + mod) + results)))))))) + (scan (cdr w) '())))) + (resolve-identifier + (lambda (id w r mod resolve-syntax-parameters?) (letrec* - ((record-definition! - (lambda (id var) - (let ((mod (cons 'hygiene (module-name (current-module))))) - (extend-ribcage! - ribcage - id - (cons (syntax-object-module id) (wrap var '((top)) mod)))))) - (macro-introduced-identifier? - (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top))))) - (fresh-derived-name - (lambda (id orig-form) - (symbol-append - (syntax-object-expression id) - '- - (string->symbol - (number->string - (hash (syntax->datum orig-form) most-positive-fixnum) - 16))))) - (parse (lambda (body r w s m esew mod) - (let lp ((body body) (exps '())) - (if (null? body) - exps - (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps)))))) - (parse1 - (lambda (x r w s m esew mod) - (letrec* - ((current-module-for-expansion - (lambda (mod) - (let ((key (car mod))) - (if (memv key '(hygiene)) - (cons 'hygiene (module-name (current-module))) - mod))))) - (call-with-values - (lambda () - (let ((mod (current-module-for-expansion mod))) - (syntax-type x r w (source-annotation x) ribcage mod #f))) - (lambda (type value form e w s mod) - (let ((key type)) - (cond ((memv key '(define-form)) - (let* ((id (wrap value w mod)) - (label (gen-label)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-object-expression id)))) - (record-definition! id var) + ((resolve-syntax-parameters + (lambda (b) + (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter)) + (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b)))) + b))) + (resolve-global + (lambda (var mod) + (let ((b (resolve-syntax-parameters + (or (get-global-definition-hook var mod) '(global))))) + (if (eq? (car b) 'global) + (values 'global var mod) + (values (car b) (cdr b) mod))))) + (resolve-lexical + (lambda (label mod) + (let ((b (resolve-syntax-parameters + (or (assq-ref r label) '(displaced-lexical))))) + (values (car b) (cdr b) mod))))) + (let ((n (id-var-name id w mod))) + (cond ((syntax-object? n) + (if (not (eq? n id)) + (resolve-identifier n w r mod resolve-syntax-parameters?) + (resolve-identifier + (syntax-object-expression n) + (syntax-object-wrap n) + r + (syntax-object-module n) + resolve-syntax-parameters?))) + ((symbol? n) + (resolve-global + n + (if (syntax-object? id) (syntax-object-module id) mod))) + ((string? n) + (resolve-lexical + n + (if (syntax-object? id) (syntax-object-module id) mod))) + (else (error "unexpected id-var-name" id w n))))))) + (transformer-environment + (make-fluid + (lambda (k) + (error "called outside the dynamic extent of a syntax transformer")))) + (with-transformer-environment + (lambda (k) ((fluid-ref transformer-environment) k))) + (free-id=? + (lambda (i j) + (let* ((mi (and (syntax-object? i) (syntax-object-module i))) + (mj (and (syntax-object? j) (syntax-object-module j))) + (ni (id-var-name i '(()) mi)) + (nj (id-var-name j '(()) mj))) + (letrec* + ((id-module-binding + (lambda (id mod) + (module-variable + (if mod (resolve-module (cdr mod)) (current-module)) + (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x)))))) + (cond ((syntax-object? ni) (free-id=? ni j)) + ((syntax-object? nj) (free-id=? i nj)) + ((symbol? ni) + (and (eq? nj + (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x))) + (let ((bi (id-module-binding i mi))) + (if bi + (eq? bi (id-module-binding j mj)) + (and (not (id-module-binding j mj)) (eq? ni nj)))) + (eq? (id-module-binding i mi) (id-module-binding j mj)))) + (else (equal? ni nj))))))) + (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? + (car (syntax-object-wrap i)) + (car (syntax-object-wrap j)))) + (eq? i j)))) + (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? + (lambda (ids) + (let distinct? ((ids ids)) + (or (null? ids) + (and (not (bound-id-member? (car ids) (cdr ids))) + (distinct? (cdr ids))))))) + (bound-id-member? + (lambda (x list) + (and (not (null? list)) + (or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) + (wrap (lambda (x w defmod) + (cond ((and (null? (car w)) (null? (cdr 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))))) + (source-wrap + (lambda (x w s defmod) (wrap (decorate-source x s) w defmod))) + (expand-sequence + (lambda (body r w s mod) + (build-sequence + s + (let dobody ((body body) (r r) (w w) (mod mod)) + (if (null? body) + '() + (let ((first (expand (car body) r w mod))) + (cons first (dobody (cdr body) r w mod)))))))) + (expand-top-sequence + (lambda (body r w s m esew mod) + (let* ((r (cons '("placeholder" placeholder) r)) + (ribcage (make-ribcage '() '() '())) + (w (cons (car w) (cons ribcage (cdr w))))) + (letrec* + ((record-definition! + (lambda (id var) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (extend-ribcage! + ribcage + id + (cons (syntax-object-module id) (wrap var '((top)) mod)))))) + (macro-introduced-identifier? + (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top))))) + (fresh-derived-name + (lambda (id orig-form) + (symbol-append + (syntax-object-expression id) + '- + (string->symbol + (number->string + (hash (syntax->datum orig-form) most-positive-fixnum) + 16))))) + (parse (lambda (body r w s m esew mod) + (let lp ((body body) (exps '())) + (if (null? body) + exps + (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps)))))) + (parse1 + (lambda (x r w s m esew mod) + (letrec* + ((current-module-for-expansion + (lambda (mod) + (let ((key (car mod))) + (if (memv key '(hygiene)) + (cons 'hygiene (module-name (current-module))) + mod))))) + (call-with-values + (lambda () + (let ((mod (current-module-for-expansion mod))) + (syntax-type x r w (source-annotation x) ribcage mod #f))) + (lambda (type value form e w s mod) + (let ((key type)) + (cond ((memv key '(define-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (list (if (eq? m 'c&e) + (let ((x (build-global-definition s var (expand e r w mod)))) + (top-level-eval-hook x mod) + (lambda () x)) + (call-with-values + (lambda () (resolve-identifier id '(()) r mod #t)) + (lambda (type* value* mod*) + (if (eq? type* 'macro) + (top-level-eval-hook + (build-global-definition s var (build-void s)) + mod)) + (lambda () (build-global-definition s var (expand e r w mod))))))))) + ((memv key '(define-syntax-form define-syntax-parameter-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (let ((key m)) + (cond ((memv key '(c)) + (cond ((memq 'compile esew) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (if (memq 'load esew) (list (lambda () e)) '()))) + ((memq 'load esew) + (list (lambda () + (expand-install-global var type (expand e r w mod))))) + (else '()))) + ((memv key '(c&e)) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (list (lambda () e)))) + (else + (if (memq 'eval esew) + (top-level-eval-hook + (expand-install-global var type (expand e r w mod)) + mod)) + '()))))) + ((memv key '(begin-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(local-syntax-form)) + (expand-local-syntax + value + e + r + w + s + mod + (lambda (forms r w s mod) (parse forms r w s m esew mod)))) + ((memv key '(eval-when-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) + (if tmp + (apply (lambda (x e1 e2) + (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) + (letrec* + ((recurse (lambda (m esew) (parse body r w s m esew mod)))) + (cond ((eq? m 'e) + (if (memq 'eval when-list) + (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval)) + (begin + (if (memq 'expand when-list) + (top-level-eval-hook + (expand-top-sequence body r w s 'e '(eval) mod) + mod)) + '()))) + ((memq 'load when-list) + (cond ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (recurse 'c&e '(compile load))) + ((memq m '(c c&e)) (recurse 'c '(load))) + (else '()))) + ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (top-level-eval-hook + (expand-top-sequence body r w s 'e '(eval) mod) + mod) + '()) + (else '()))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + (else (list (if (eq? m 'c&e) - (let ((x (build-global-definition s var (expand e r w mod)))) + (let ((x (expand-expr type value form e r w s mod))) (top-level-eval-hook x mod) (lambda () x)) - (call-with-values - (lambda () (resolve-identifier id '(()) r mod #t)) - (lambda (type* value* mod*) - (if (eq? type* 'macro) - (top-level-eval-hook - (build-global-definition s var (build-void s)) - mod)) - (lambda () (build-global-definition s var (expand e r w mod))))))))) - ((memv key '(define-syntax-form define-syntax-parameter-form)) - (let* ((id (wrap value w mod)) - (label (gen-label)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-object-expression id)))) - (record-definition! id var) - (let ((key m)) - (cond ((memv key '(c)) - (cond ((memq 'compile esew) - (let ((e (expand-install-global var type (expand e r w mod)))) - (top-level-eval-hook e mod) - (if (memq 'load esew) (list (lambda () e)) '()))) - ((memq 'load esew) - (list (lambda () (expand-install-global var type (expand e r w mod))))) - (else '()))) - ((memv key '(c&e)) - (let ((e (expand-install-global var type (expand e r w mod)))) - (top-level-eval-hook e mod) - (list (lambda () e)))) - (else - (if (memq 'eval esew) - (top-level-eval-hook - (expand-install-global var type (expand e r w mod)) - mod)) - '()))))) - ((memv key '(begin-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) - (if tmp - (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp) + (lambda () (expand-expr type value form e r w s mod))))))))))))) + (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) + (if (null? exps) (build-void s) (build-sequence s exps))))))) + (expand-install-global + (lambda (name type e) + (build-global-definition + #f + name + (build-primcall + #f + 'make-syntax-transformer + (if (eq? type 'define-syntax-parameter-form) + (list (build-data #f name) + (build-data #f 'syntax-parameter) + (build-primcall #f 'list (list e))) + (list (build-data #f name) (build-data #f 'macro) e)))))) + (parse-when-list + (lambda (e when-list) + (let ((result (strip when-list '(())))) + (let lp ((l result)) + (cond ((null? l) result) + ((memq (car l) '(compile load eval expand)) (lp (cdr l))) + (else (syntax-violation 'eval-when "invalid situation" e (car l)))))))) + (syntax-type + (lambda (e r w s rib mod for-car?) + (cond ((symbol? e) + (call-with-values + (lambda () (resolve-identifier e w r mod #t)) + (lambda (type value mod*) + (let ((key type)) + (cond ((memv key '(macro)) + (if for-car? + (values type value e e w s mod) + (syntax-type + (expand-macro value e r w s rib mod) + r + '(()) + s + rib + mod + #f))) + ((memv key '(global)) (values type value e value w s mod*)) + (else (values type value e e w s mod))))))) + ((pair? e) + (let ((first (car e))) + (call-with-values + (lambda () (syntax-type first r w s rib mod #t)) + (lambda (ftype fval fform fe fw fs fmod) + (let ((key ftype)) + (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod)) + ((memv key '(global)) + (if (equal? fmod '(primitive)) + (values 'primitive-call fval e e w s mod) + (values 'global-call (make-syntax-object fval w fmod) e e w s mod))) + ((memv key '(macro)) + (syntax-type + (expand-macro fval e r w s rib mod) + r + '(()) + s + rib + mod + for-car?)) + ((memv key '(module-ref)) + (call-with-values + (lambda () (fval e r w mod)) + (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?)))) + ((memv key '(core)) (values 'core-form fval e e w s mod)) + ((memv key '(local-syntax)) + (values 'local-syntax-form fval e e w s mod)) + ((memv key '(begin)) (values 'begin-form #f e e w s mod)) + ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod)) + ((memv key '(define)) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) + (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1)) + (apply (lambda (name val) (values 'define-form name e val w s mod)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any)))) + (if (and tmp-1 + (apply (lambda (name args e1 e2) + (and (id? name) (valid-bound-ids? (lambda-var-list args)))) + tmp-1)) + (apply (lambda (name args e1 e2) + (values + 'define-form + (wrap name w mod) + (wrap e w mod) + (decorate-source + (cons '#(syntax-object lambda ((top)) (hygiene guile)) + (wrap (cons args (cons e1 e2)) w mod)) + s) + '(()) + s + mod)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ any)))) + (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1)) + (apply (lambda (name) + (values + 'define-form + (wrap name w mod) + (wrap e w mod) + '(#(syntax-object if ((top)) (hygiene guile)) #f #f) + '(()) + s + mod)) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))) + ((memv key '(define-syntax)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (and tmp (apply (lambda (name val) (id? name)) tmp)) + (apply (lambda (name val) (values 'define-syntax-form name e val w s mod)) + tmp) (syntax-violation #f "source expression failed to match any pattern" tmp-1)))) - ((memv key '(local-syntax-form)) - (expand-local-syntax - value - e - r - w - s - mod - (lambda (forms r w s mod) (parse forms r w s m esew mod)))) - ((memv key '(eval-when-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) - (if tmp - (apply (lambda (x e1 e2) - (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) - (letrec* - ((recurse (lambda (m esew) (parse body r w s m esew mod)))) - (cond ((eq? m 'e) - (if (memq 'eval when-list) - (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval)) - (begin - (if (memq 'expand when-list) - (top-level-eval-hook - (expand-top-sequence body r w s 'e '(eval) mod) - mod)) - '()))) - ((memq 'load when-list) - (cond ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (recurse 'c&e '(compile load))) - ((memq m '(c c&e)) (recurse 'c '(load))) - (else '()))) - ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (top-level-eval-hook - (expand-top-sequence body r w s 'e '(eval) mod) - mod) - '()) - (else '()))))) + ((memv key '(define-syntax-parameter)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (and tmp (apply (lambda (name val) (id? name)) tmp)) + (apply (lambda (name val) + (values 'define-syntax-parameter-form name e val w s mod)) tmp) (syntax-violation #f "source expression failed to match any pattern" tmp-1)))) - (else - (list (if (eq? m 'c&e) - (let ((x (expand-expr type value form e r w s mod))) - (top-level-eval-hook x mod) - (lambda () x)) - (lambda () (expand-expr type value form e r w s mod))))))))))))) - (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) - (if (null? exps) (build-void s) (build-sequence s exps))))))) - (expand-install-global - (lambda (name type e) - (build-global-definition - #f - name - (build-primcall - #f - 'make-syntax-transformer - (if (eq? type 'define-syntax-parameter-form) - (list (build-data #f name) - (build-data #f 'syntax-parameter) - (build-primcall #f 'list (list e))) - (list (build-data #f name) (build-data #f 'macro) e)))))) - (parse-when-list - (lambda (e when-list) - (let ((result (strip when-list '(())))) - (let lp ((l result)) - (cond ((null? l) result) - ((memq (car l) '(compile load eval expand)) (lp (cdr l))) - (else (syntax-violation 'eval-when "invalid situation" e (car l)))))))) - (syntax-type - (lambda (e r w s rib mod for-car?) - (cond ((symbol? e) - (call-with-values - (lambda () (resolve-identifier e w r mod #t)) - (lambda (type value mod*) - (let ((key type)) - (cond ((memv key '(macro)) - (if for-car? - (values type value e e w s mod) - (syntax-type - (expand-macro value e r w s rib mod) - r - '(()) - s - rib - mod - #f))) - ((memv key '(global)) (values type value e value w s mod*)) - (else (values type value e e w s mod))))))) - ((pair? e) - (let ((first (car e))) - (call-with-values - (lambda () (syntax-type first r w s rib mod #t)) - (lambda (ftype fval fform fe fw fs fmod) - (let ((key ftype)) - (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod)) - ((memv key '(global)) - (if (equal? fmod '(primitive)) - (values 'primitive-call fval e e w s mod) - (values 'global-call (make-syntax-object fval w fmod) e e w s mod))) - ((memv key '(macro)) - (syntax-type - (expand-macro fval e r w s rib mod) - r - '(()) - s - rib - mod - for-car?)) - ((memv key '(module-ref)) - (call-with-values - (lambda () (fval e r w mod)) - (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?)))) - ((memv key '(core)) (values 'core-form fval e e w s mod)) - ((memv key '(local-syntax)) - (values 'local-syntax-form fval e e w s mod)) - ((memv key '(begin)) (values 'begin-form #f e e w s mod)) - ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod)) - ((memv key '(define)) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) - (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1)) - (apply (lambda (name val) (values 'define-form name e val w s mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any)))) - (if (and tmp-1 - (apply (lambda (name args e1 e2) - (and (id? name) (valid-bound-ids? (lambda-var-list args)))) - tmp-1)) - (apply (lambda (name args e1 e2) - (values - 'define-form - (wrap name w mod) - (wrap e w mod) - (decorate-source - (cons '#(syntax-object lambda ((top)) (hygiene guile)) - (wrap (cons args (cons e1 e2)) w mod)) - s) - '(()) - s - mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any)))) - (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1)) - (apply (lambda (name) - (values - 'define-form - (wrap name w mod) - (wrap e w mod) - '(#(syntax-object if ((top)) (hygiene guile)) #f #f) - '(()) - s - mod)) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))) - ((memv key '(define-syntax)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (and tmp (apply (lambda (name val) (id? name)) tmp)) - (apply (lambda (name val) (values 'define-syntax-form name e val w s mod)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(define-syntax-parameter)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (and tmp (apply (lambda (name val) (id? name)) tmp)) - (apply (lambda (name val) - (values 'define-syntax-parameter-form name e val w s mod)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - (else (values 'call #f e e w s mod)))))))) - ((syntax-object? e) - (syntax-type - (syntax-object-expression e) - r - (join-wraps w (syntax-object-wrap e)) - (or (source-annotation e) s) - rib - (or (syntax-object-module e) mod) - for-car?)) - ((self-evaluating? e) (values 'constant #f e e w s mod)) - (else (values 'other #f e e w s mod))))) - (expand - (lambda (e r w mod) - (call-with-values - (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) - (lambda (type value form e w s mod) - (expand-expr type value form e r w s mod))))) - (expand-expr - (lambda (type value form e r w s mod) - (let ((key type)) - (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value)) - ((memv key '(core core-form)) (value e r w s mod)) - ((memv key '(module-ref)) - (call-with-values - (lambda () (value e r w mod)) - (lambda (e r w s mod) (expand e r w mod)))) - ((memv key '(lexical-call)) - (expand-call - (let ((id (car e))) - (build-lexical-reference - 'fun - (source-annotation id) - (if (syntax-object? id) (syntax->datum id) id) - value)) - e - r - w - s - mod)) - ((memv key '(global-call)) - (expand-call - (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 + (else (values 'call #f e e w s mod)))))))) + ((syntax-object? e) + (syntax-type + (syntax-object-expression e) r - w - s - mod)) - ((memv key '(primitive-call)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) - (if tmp - (apply (lambda (e) - (build-primcall s value (map (lambda (e) (expand e r w mod)) e))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(constant)) - (build-data s (strip (source-wrap e w s mod) '(())))) - ((memv key '(global)) (build-global-reference s value mod)) - ((memv key '(call)) - (expand-call (expand (car e) r w mod) e r w s mod)) - ((memv key '(begin-form)) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any)))) - (if tmp-1 - (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_)))) - (if tmp-1 - (apply (lambda () - (syntax-violation - #f - "sequence of zero expressions" - (source-wrap e w s mod))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))) - ((memv key '(local-syntax-form)) - (expand-local-syntax value e r w s mod expand-sequence)) - ((memv key '(eval-when-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) - (if tmp - (apply (lambda (x e1 e2) - (let ((when-list (parse-when-list e x))) - (if (memq 'eval when-list) - (expand-sequence (cons e1 e2) r w s mod) - (expand-void)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key - '(define-form define-syntax-form define-syntax-parameter-form)) - (syntax-violation - #f - "definition in expression context, where definitions are not allowed," - (source-wrap form w s mod))) - ((memv key '(syntax)) - (syntax-violation - #f - "reference to pattern variable outside syntax form" - (source-wrap e w s mod))) - ((memv key '(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))))))) - (expand-call - (lambda (x e r w s mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any)))) - (if tmp - (apply (lambda (e0 e1) - (build-call s x (map (lambda (e) (expand e r w mod)) e1))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) - (expand-macro - (lambda (p e r w s rib mod) - (letrec* - ((rebuild-macro-output - (lambda (x m) - (cond ((pair? x) - (decorate-source - (cons (rebuild-macro-output (car x) m) - (rebuild-macro-output (cdr x) m)) - s)) - ((syntax-object? x) - (let ((w (syntax-object-wrap x))) - (let ((ms (car w)) (ss (cdr w))) - (if (and (pair? ms) (eq? (car ms) #f)) - (make-syntax-object - (syntax-object-expression x) - (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) - (syntax-object-module x)) - (make-syntax-object - (decorate-source (syntax-object-expression x) s) - (cons (cons m ms) - (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) - (syntax-object-module x)))))) - ((vector? x) - (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) - (let loop ((i 0)) - (if (= i n) - (begin (if #f #f) v) - (begin - (vector-set! v i (rebuild-macro-output (vector-ref x i) m)) - (loop (+ i 1))))))) - ((symbol? x) - (syntax-violation - #f - "encountered raw symbol in macro output" - (source-wrap e w (cdr w) mod) - x)) - (else (decorate-source x s)))))) - (let* ((t-680b775fb37a463-7fe transformer-environment) - (t-680b775fb37a463-7ff (lambda (k) (k e r w s rib mod)))) - (with-fluid* - t-680b775fb37a463-7fe - t-680b775fb37a463-7ff - (lambda () - (rebuild-macro-output - (p (source-wrap e (anti-mark w) s mod)) - (module-gensym "m")))))))) - (expand-body - (lambda (body outer-form r w mod) - (let* ((r (cons '("placeholder" placeholder) r)) - (ribcage (make-ribcage '() '() '())) - (w (cons (car w) (cons ribcage (cdr 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 '(()) (source-annotation e) ribcage mod #f)) - (lambda (type value form e w s mod) - (let ((key type)) - (cond ((memv key '(define-form)) - (let ((id (wrap value w mod)) (label (gen-label))) - (let ((var (gen-var id))) + (join-wraps w (syntax-object-wrap e)) + (or (source-annotation e) s) + rib + (or (syntax-object-module e) mod) + for-car?)) + ((self-evaluating? e) (values 'constant #f e e w s mod)) + (else (values 'other #f e e w s mod))))) + (expand + (lambda (e r w mod) + (call-with-values + (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) + (lambda (type value form e w s mod) + (expand-expr type value form e r w s mod))))) + (expand-expr + (lambda (type value form e r w s mod) + (let ((key type)) + (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value)) + ((memv key '(core core-form)) (value e r w s mod)) + ((memv key '(module-ref)) + (call-with-values + (lambda () (value e r w mod)) + (lambda (e r w s mod) (expand e r w mod)))) + ((memv key '(lexical-call)) + (expand-call + (let ((id (car e))) + (build-lexical-reference + 'fun + (source-annotation id) + (if (syntax-object? id) (syntax->datum id) id) + value)) + e + r + w + s + mod)) + ((memv key '(global-call)) + (expand-call + (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)) + ((memv key '(primitive-call)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e) + (build-primcall s value (map (lambda (e) (expand e r w mod)) e))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(constant)) + (build-data s (strip (source-wrap e w s mod) '(())))) + ((memv key '(global)) (build-global-reference s value mod)) + ((memv key '(call)) + (expand-call (expand (car e) r w mod) e r w s mod)) + ((memv key '(begin-form)) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any)))) + (if tmp-1 + (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_)))) + (if tmp-1 + (apply (lambda () + (syntax-violation + #f + "sequence of zero expressions" + (source-wrap e w s mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))) + ((memv key '(local-syntax-form)) + (expand-local-syntax value e r w s mod expand-sequence)) + ((memv key '(eval-when-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) + (if tmp + (apply (lambda (x e1 e2) + (let ((when-list (parse-when-list e x))) + (if (memq 'eval when-list) + (expand-sequence (cons e1 e2) r w s mod) + (expand-void)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key + '(define-form define-syntax-form define-syntax-parameter-form)) + (syntax-violation + #f + "definition in expression context, where definitions are not allowed," + (source-wrap form w s mod))) + ((memv key '(syntax)) + (syntax-violation + #f + "reference to pattern variable outside syntax form" + (source-wrap e w s mod))) + ((memv key '(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))))))) + (expand-call + (lambda (x e r w s mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any)))) + (if tmp + (apply (lambda (e0 e1) + (build-call s x (map (lambda (e) (expand e r w mod)) e1))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))) + (expand-macro + (lambda (p e r w s rib mod) + (letrec* + ((rebuild-macro-output + (lambda (x m) + (cond ((pair? x) + (decorate-source + (cons (rebuild-macro-output (car x) m) + (rebuild-macro-output (cdr x) m)) + s)) + ((syntax-object? x) + (let ((w (syntax-object-wrap x))) + (let ((ms (car w)) (ss (cdr w))) + (if (and (pair? ms) (eq? (car ms) #f)) + (make-syntax-object + (syntax-object-expression x) + (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) + (syntax-object-module x)) + (make-syntax-object + (decorate-source (syntax-object-expression x) s) + (cons (cons m ms) + (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) + (syntax-object-module x)))))) + ((vector? x) + (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) + (let loop ((i 0)) + (if (= i n) + (begin (if #f #f) v) + (begin + (vector-set! v i (rebuild-macro-output (vector-ref x i) m)) + (loop (+ i 1))))))) + ((symbol? x) + (syntax-violation + #f + "encountered raw symbol in macro output" + (source-wrap e w (cdr w) mod) + x)) + (else (decorate-source x s)))))) + (let* ((t-680b775fb37a463-7f9 transformer-environment) + (t-680b775fb37a463-7fa (lambda (k) (k e r w s rib mod)))) + (with-fluid* + t-680b775fb37a463-7f9 + t-680b775fb37a463-7fa + (lambda () + (rebuild-macro-output + (p (source-wrap e (anti-mark w) s mod)) + (module-gensym "m")))))))) + (expand-body + (lambda (body outer-form r w mod) + (let* ((r (cons '("placeholder" placeholder) r)) + (ribcage (make-ribcage '() '() '())) + (w (cons (car w) (cons ribcage (cdr 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 '(()) (source-annotation e) ribcage mod #f)) + (lambda (type value form e w s mod) + (let ((key type)) + (cond ((memv key '(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 (cons 'lexical var) bindings))))) + ((memv key '(define-syntax-form)) + (let ((id (wrap value w mod)) + (label (gen-label)) + (trans-r (macros-only-env er))) (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 (cons 'lexical var) bindings))))) - ((memv key '(define-syntax-form)) - (let ((id (wrap value w mod)) - (label (gen-label)) - (trans-r (macros-only-env er))) - (extend-ribcage! ribcage id label) - (set-cdr! - r - (extend-env - (list label) - (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod))) - (cdr r))) - (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) - ((memv key '(define-syntax-parameter-form)) - (let ((id (wrap value w mod)) - (label (gen-label)) - (trans-r (macros-only-env er))) - (extend-ribcage! ribcage id label) - (set-cdr! - r - (extend-env - (list label) - (list (cons 'syntax-parameter - (list (eval-local-transformer (expand e trans-r w mod) mod)))) - (cdr r))) - (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) - ((memv key '(begin-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) - (if tmp - (apply (lambda (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)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(local-syntax-form)) - (expand-local-syntax - value - e - er - w - s - mod - (lambda (forms er w s mod) - (parse (let f ((forms forms)) - (if (null? forms) - (cdr body) - (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids - labels - var-ids - vars - vals - bindings)))) - ((null? ids) - (build-sequence - #f - (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) - (cons (cons er (source-wrap e w s mod)) (cdr body))))) - (else - (if (not (valid-bound-ids? ids)) - (syntax-violation - #f - "invalid or duplicate identifier in definition" - outer-form)) - (set-cdr! r (extend-env labels bindings (cdr r))) - (build-letrec - #f - #t - (reverse (map syntax->datum var-ids)) - (reverse vars) - (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals)) + (set-cdr! + r + (extend-env + (list label) + (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod))) + (cdr r))) + (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) + ((memv key '(define-syntax-parameter-form)) + (let ((id (wrap value w mod)) + (label (gen-label)) + (trans-r (macros-only-env er))) + (extend-ribcage! ribcage id label) + (set-cdr! + r + (extend-env + (list label) + (list (cons 'syntax-parameter + (list (eval-local-transformer (expand e trans-r w mod) mod)))) + (cdr r))) + (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) + ((memv key '(begin-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (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)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(local-syntax-form)) + (expand-local-syntax + value + e + er + w + s + mod + (lambda (forms er w s mod) + (parse (let f ((forms forms)) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) + ids + labels + var-ids + vars + vals + bindings)))) + ((null? ids) (build-sequence #f (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) - (cons (cons er (source-wrap e w s mod)) (cdr body)))))))))))))))) - (expand-local-syntax - (lambda (rec? e r w s mod k) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if tmp - (apply (lambda (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)) (new-w (make-binding-wrap ids labels w))) - (k (cons e1 e2) - (extend-env - labels - (let ((w (if rec? new-w w)) (trans-r (macros-only-env r))) - (map (lambda (x) - (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) - val)) - r) - new-w - s - mod))))) - tmp) - (syntax-violation - #f - "bad local syntax definition" - (source-wrap e w s mod)))))) - (eval-local-transformer - (lambda (expanded mod) - (let ((p (local-eval-hook expanded mod))) - (if (procedure? p) - p - (syntax-violation #f "nonprocedure transformer" p))))) - (expand-void (lambda () (build-void #f))) - (ellipsis? - (lambda (e r mod) - (and (nonsymbol-id? e) - (call-with-values - (lambda () - (resolve-identifier - (make-syntax-object - '#{ $sc-ellipsis }# - (syntax-object-wrap e) - (syntax-object-module e)) - '(()) - r - mod - #f)) - (lambda (type value mod) - (if (eq? type 'ellipsis) - (bound-id=? e value) - (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))) - (lambda-formals - (lambda (orig-args) - (letrec* - ((req (lambda (args rreq) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check (reverse rreq) #f)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) (req b (cons a rreq))) tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (check (reverse rreq) r)) tmp-1) - (let ((else tmp)) - (syntax-violation 'lambda "invalid argument list" orig-args args)))))))))) - (check (lambda (req rest) - (if (distinct-bound-ids? (if rest (cons rest req) req)) - (values req #f rest #f) - (syntax-violation - 'lambda - "duplicate identifier in argument list" - orig-args))))) - (req orig-args '())))) - (expand-simple-lambda - (lambda (e r w s mod req rest meta body) - (let* ((ids (if rest (append req (list rest)) req)) - (vars (map gen-var ids)) - (labels (gen-labels ids))) - (build-simple-lambda - s - (map syntax->datum req) - (and rest (syntax->datum rest)) - vars - meta - (expand-body - body - (source-wrap e w s mod) - (extend-var-env labels vars r) - (make-binding-wrap ids labels w) - mod))))) - (lambda*-formals - (lambda (orig-args) - (letrec* - ((req (lambda (args rreq) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) (req b (cons a rreq))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1)) - (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) - (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) - (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1) - (let ((else tmp)) - (syntax-violation - 'lambda* - "invalid argument list" - orig-args - args)))))))))))))))) - (opt (lambda (args req ropt) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check req (reverse ropt) #f '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) - (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) - (apply (lambda (a init b) (opt b req (cons (list a init) ropt))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) - (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) - (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1) - (let ((else tmp)) - (syntax-violation - 'lambda* - "invalid optional argument list" - orig-args - args)))))))))))))))) - (key (lambda (args req opt rkey) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) - (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) - (key b req opt (cons (cons k (cons a '(#f))) rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) - (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) - (apply (lambda (a init b) - (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) - (key b req opt (cons (list k a init) rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any)))) - (if (and tmp-1 - (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k)))) - tmp-1)) - (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any)))) - (if (and tmp-1 - (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys)) - tmp-1)) - (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any any)))) - (if (and tmp-1 - (apply (lambda (aok a b) - (and (eq? (syntax->datum aok) #:allow-other-keys) - (eq? (syntax->datum a) #:rest))) - tmp-1)) - (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (aok r) - (and (eq? (syntax->datum aok) #:allow-other-keys) (id? r))) - tmp-1)) - (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) - (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey)))) - tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (rest r req opt (cons #f (reverse rkey)))) - tmp-1) - (let ((else tmp)) - (syntax-violation - 'lambda* - "invalid keyword argument list" - orig-args - args)))))))))))))))))))))) - (rest (lambda (args req opt kw) - (let* ((tmp-1 args) (tmp (list tmp-1))) - (if (and tmp (apply (lambda (r) (id? r)) tmp)) - (apply (lambda (r) (check req opt r kw)) tmp) - (let ((else tmp-1)) - (syntax-violation 'lambda* "invalid rest argument" orig-args args)))))) - (check (lambda (req opt rest kw) - (if (distinct-bound-ids? - (append + (cons (cons er (source-wrap e w s mod)) (cdr body))))) + (else + (if (not (valid-bound-ids? ids)) + (syntax-violation + #f + "invalid or duplicate identifier in definition" + outer-form)) + (set-cdr! r (extend-env labels bindings (cdr r))) + (build-letrec + #f + #t + (reverse (map syntax->datum var-ids)) + (reverse vars) + (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals)) + (build-sequence + #f + (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) + (cons (cons er (source-wrap e w s mod)) (cdr body)))))))))))))))) + (expand-local-syntax + (lambda (rec? e r w s mod k) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if tmp + (apply (lambda (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)) (new-w (make-binding-wrap ids labels w))) + (k (cons e1 e2) + (extend-env + labels + (let ((w (if rec? new-w w)) (trans-r (macros-only-env r))) + (map (lambda (x) + (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) + val)) + r) + new-w + s + mod))))) + tmp) + (syntax-violation + #f + "bad local syntax definition" + (source-wrap e w s mod)))))) + (eval-local-transformer + (lambda (expanded mod) + (let ((p (local-eval-hook expanded mod))) + (if (procedure? p) + p + (syntax-violation #f "nonprocedure transformer" p))))) + (expand-void (lambda () (build-void #f))) + (ellipsis? + (lambda (e r mod) + (and (nonsymbol-id? e) + (call-with-values + (lambda () + (resolve-identifier + (make-syntax-object + '#{ $sc-ellipsis }# + (syntax-object-wrap e) + (syntax-object-module e)) + '(()) + r + mod + #f)) + (lambda (type value mod) + (if (eq? type 'ellipsis) + (bound-id=? e value) + (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))) + (lambda-formals + (lambda (orig-args) + (letrec* + ((req (lambda (args rreq) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check (reverse rreq) #f)) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) (req b (cons a rreq))) tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (check (reverse rreq) r)) tmp-1) + (let ((else tmp)) + (syntax-violation 'lambda "invalid argument list" orig-args args)))))))))) + (check (lambda (req rest) + (if (distinct-bound-ids? (if rest (cons rest req) req)) + (values req #f rest #f) + (syntax-violation + 'lambda + "duplicate identifier in argument list" + orig-args))))) + (req orig-args '())))) + (expand-simple-lambda + (lambda (e r w s mod req rest meta body) + (let* ((ids (if rest (append req (list rest)) req)) + (vars (map gen-var ids)) + (labels (gen-labels ids))) + (build-simple-lambda + s + (map syntax->datum req) + (and rest (syntax->datum rest)) + vars + meta + (expand-body + body + (source-wrap e w s mod) + (extend-var-env labels vars r) + (make-binding-wrap ids labels w) + mod))))) + (lambda*-formals + (lambda (orig-args) + (letrec* + ((req (lambda (args rreq) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) (req b (cons a rreq))) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1)) + (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) + (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) + (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1) + (let ((else tmp)) + (syntax-violation + 'lambda* + "invalid argument list" + orig-args + args)))))))))))))))) + (opt (lambda (args req ropt) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check req (reverse ropt) #f '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) + (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) + (apply (lambda (a init b) (opt b req (cons (list a init) ropt))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) + (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) + (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1) + (let ((else tmp)) + (syntax-violation + 'lambda* + "invalid optional argument list" + orig-args + args)))))))))))))))) + (key (lambda (args req opt rkey) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) + (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) + (key b req opt (cons (cons k (cons a '(#f))) rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) + (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) + (apply (lambda (a init b) + (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) + (key b req opt (cons (list k a init) rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any)))) + (if (and tmp-1 + (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k)))) + tmp-1)) + (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any)))) + (if (and tmp-1 + (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys)) + tmp-1)) + (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any any)))) + (if (and tmp-1 + (apply (lambda (aok a b) + (and (eq? (syntax->datum aok) #:allow-other-keys) + (eq? (syntax->datum a) #:rest))) + tmp-1)) + (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 + (apply (lambda (aok r) + (and (eq? (syntax->datum aok) #:allow-other-keys) + (id? r))) + tmp-1)) + (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) + (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey)))) + tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (rest r req opt (cons #f (reverse rkey)))) + tmp-1) + (let ((else tmp)) + (syntax-violation + 'lambda* + "invalid keyword argument list" + orig-args + args)))))))))))))))))))))) + (rest (lambda (args req opt kw) + (let* ((tmp-1 args) (tmp (list tmp-1))) + (if (and tmp (apply (lambda (r) (id? r)) tmp)) + (apply (lambda (r) (check req opt r kw)) tmp) + (let ((else tmp-1)) + (syntax-violation 'lambda* "invalid rest argument" orig-args args)))))) + (check (lambda (req opt rest kw) + (if (distinct-bound-ids? + (append + req + (map car opt) + (if rest (list rest) '()) + (if (pair? kw) (map cadr (cdr kw)) '()))) + (values req opt rest kw) + (syntax-violation + 'lambda* + "duplicate identifier in argument list" + orig-args))))) + (req orig-args '())))) + (expand-lambda-case + (lambda (e r w s mod get-formals clauses) + (letrec* + ((parse-req + (lambda (req opt rest kw body) + (let ((vars (map gen-var req)) (labels (gen-labels req))) + (let ((r* (extend-var-env labels vars r)) + (w* (make-binding-wrap req labels w))) + (parse-opt + (map syntax->datum req) + opt + rest + kw + body + (reverse vars) + r* + w* + '() + '()))))) + (parse-opt + (lambda (req opt rest kw body vars r* w* out inits) + (cond ((pair? opt) + (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (id i) + (let* ((v (gen-var id)) + (l (gen-labels (list v))) + (r** (extend-var-env l (list v) r*)) + (w** (make-binding-wrap (list id) l w*))) + (parse-opt + req + (cdr opt) + rest + kw + body + (cons v vars) + r** + w** + (cons (syntax->datum id) out) + (cons (expand i r* w* mod) inits)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + (rest + (let* ((v (gen-var rest)) + (l (gen-labels (list v))) + (r* (extend-var-env l (list v) r*)) + (w* (make-binding-wrap (list rest) l w*))) + (parse-kw req - (map car opt) - (if rest (list rest) '()) - (if (pair? kw) (map cadr (cdr kw)) '()))) - (values req opt rest kw) - (syntax-violation - 'lambda* - "duplicate identifier in argument list" - orig-args))))) - (req orig-args '())))) - (expand-lambda-case - (lambda (e r w s mod get-formals clauses) - (letrec* - ((parse-req - (lambda (req opt rest kw body) - (let ((vars (map gen-var req)) (labels (gen-labels req))) - (let ((r* (extend-var-env labels vars r)) - (w* (make-binding-wrap req labels w))) - (parse-opt - (map syntax->datum req) - opt - rest - kw - body - (reverse vars) - r* - w* - '() - '()))))) - (parse-opt - (lambda (req opt rest kw body vars r* w* out inits) - (cond ((pair? opt) - (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (id i) - (let* ((v (gen-var id)) - (l (gen-labels (list v))) - (r** (extend-var-env l (list v) r*)) - (w** (make-binding-wrap (list id) l w*))) - (parse-opt - req - (cdr opt) - rest - kw - body - (cons v vars) - r** - w** - (cons (syntax->datum id) out) - (cons (expand i r* w* mod) inits)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - (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*))) + (and (pair? out) (reverse out)) + (syntax->datum rest) + (if (pair? kw) (cdr kw) kw) + body + (cons v vars) + r* + w* + (and (pair? kw) (car kw)) + '() + inits))) + (else (parse-kw req (and (pair? out) (reverse out)) - (syntax->datum rest) + #f (if (pair? kw) (cdr kw) kw) body - (cons v vars) + vars r* w* (and (pair? kw) (car kw)) '() - inits))) - (else - (parse-kw - req - (and (pair? out) (reverse out)) - #f - (if (pair? kw) (cdr kw) kw) - body - vars - r* - w* - (and (pair? kw) (car kw)) - '() - inits))))) - (parse-kw - (lambda (req opt rest kw body vars r* w* aok out inits) - (if (pair? kw) - (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any)))) - (if tmp - (apply (lambda (k id i) - (let* ((v (gen-var id)) - (l (gen-labels (list v))) - (r** (extend-var-env l (list v) r*)) - (w** (make-binding-wrap (list id) l w*))) - (parse-kw - req - opt - rest - (cdr kw) - body - (cons v vars) - r** - w** - aok - (cons (list (syntax->datum k) (syntax->datum id) v) out) - (cons (expand i r* w* mod) inits)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))) - (parse-body - req - opt - rest - (and (or aok (pair? out)) (cons aok (reverse out))) - body - (reverse vars) - r* - w* - (reverse inits) - '())))) - (parse-body - (lambda (req opt rest kw body vars r* w* inits meta) - (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any)))) - (if (and tmp-1 - (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) - tmp-1)) - (apply (lambda (docstring e1 e2) - (parse-body - req - opt - rest - kw - (cons e1 e2) - vars - r* - w* - inits - (append meta (list (cons 'documentation (syntax->datum docstring)))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any)))) - (if tmp-1 - (apply (lambda (k v e1 e2) - (parse-body - req - opt - rest - kw - (cons e1 e2) - vars - r* - w* - inits - (append meta (syntax->datum (map cons k v))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . each-any)))) - (if tmp-1 - (apply (lambda (e1 e2) - (values - meta - req - opt - rest - kw - inits - vars - (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))))) - (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (values '() #f)) tmp-1) - (let ((tmp-1 ($sc-dispatch - tmp - '((any any . each-any) . #(each (any any . each-any)))))) - (if tmp-1 - (apply (lambda (args e1 e2 args* e1* e2*) - (call-with-values - (lambda () (get-formals args)) - (lambda (req opt rest kw) - (call-with-values - (lambda () (parse-req req opt rest kw (cons e1 e2))) - (lambda (meta req opt rest kw inits vars body) - (call-with-values - (lambda () - (expand-lambda-case - e - r - w - s - mod - get-formals - (map (lambda (tmp-680b775fb37a463-aef - tmp-680b775fb37a463-aee - tmp-680b775fb37a463-aed) - (cons tmp-680b775fb37a463-aed - (cons tmp-680b775fb37a463-aee tmp-680b775fb37a463-aef))) - e2* - e1* - args*))) - (lambda (meta* else*) - (values - (append meta meta*) - (build-lambda-case s req opt rest kw inits vars body else*))))))))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))) - (strip (lambda (x w) - (if (memq 'top (car 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)) (new (map f old))) - (let lp ((l1 old) (l2 new)) - (cond ((null? l1) x) - ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2))) - (else (list->vector new)))))) - (else x)))))) - (gen-var - (lambda (id) - (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (module-gensym (symbol->string id))))) - (lambda-var-list - (lambda (vars) - (let lvl ((vars vars) (ls '()) (w '(()))) - (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) - ((id? vars) (cons (wrap vars w #f) ls)) - ((null? vars) ls) - ((syntax-object? vars) - (lvl (syntax-object-expression vars) - ls - (join-wraps w (syntax-object-wrap vars)))) - (else (cons vars ls))))))) - (global-extend 'local-syntax 'letrec-syntax #t) - (global-extend 'local-syntax 'let-syntax #f) - (global-extend - 'core - 'syntax-parameterize - (lambda (e r w s mod) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp)) - (apply (lambda (var val e1 e2) - (let ((names (map (lambda (x) - (call-with-values - (lambda () (resolve-identifier x w r mod #f)) - (lambda (type value mod) - (let ((key type)) - (cond ((memv key '(displaced-lexical)) - (syntax-violation - 'syntax-parameterize - "identifier out of context" - e - (source-wrap x w s mod))) - ((memv key '(syntax-parameter)) value) - (else - (syntax-violation - 'syntax-parameterize - "invalid syntax parameter" - e - (source-wrap x w s mod)))))))) - var)) - (bindings - (let ((trans-r (macros-only-env r))) - (map (lambda (x) - (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) - val)))) - (expand-body - (cons e1 e2) - (source-wrap e w s mod) - (extend-env names bindings r) - w - mod))) - tmp) - (syntax-violation - 'syntax-parameterize - "bad syntax" - (source-wrap e w s mod)))))) - (global-extend - 'core - 'quote - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) - (if tmp - (apply (lambda (e) (build-data s (strip e w))) tmp) - (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) - (global-extend - 'core - 'syntax - (letrec* - ((gen-syntax - (lambda (src e r maps ellipsis? mod) - (if (id? e) - (call-with-values - (lambda () (resolve-identifier e '(()) r mod #f)) - (lambda (type value mod) - (let ((key type)) - (cond ((memv key '(syntax)) - (call-with-values - (lambda () (gen-ref src (car value) (cdr value) maps)) - (lambda (var maps) (values (list 'ref var) maps)))) - ((ellipsis? e r mod) - (syntax-violation 'syntax "misplaced ellipsis" src)) - (else (values (list 'quote e) maps)))))) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) - (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) - (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1)) - (apply (lambda (x dots y) - (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)))))))) - (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) - (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) - (apply (lambda (dots y) - (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)))))))) - tmp) + inits))))) + (parse-kw + (lambda (req opt rest kw body vars r* w* aok out inits) + (if (pair? kw) + (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any)))) + (if tmp + (apply (lambda (k id i) + (let* ((v (gen-var id)) + (l (gen-labels (list v))) + (r** (extend-var-env l (list v) r*)) + (w** (make-binding-wrap (list id) l w*))) + (parse-kw + req + opt + rest + (cdr kw) + body + (cons v vars) + r** + w** + aok + (cons (list (syntax->datum k) (syntax->datum id) v) out) + (cons (expand i r* w* mod) inits)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))) + (parse-body + req + opt + rest + (and (or aok (pair? out)) (cons aok (reverse out))) + body + (reverse vars) + r* + w* + (reverse inits) + '())))) + (parse-body + (lambda (req opt rest kw body vars r* w* inits meta) + (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any)))) + (if (and tmp-1 + (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) + tmp-1)) + (apply (lambda (docstring e1 e2) + (parse-body + req + opt + rest + kw + (cons e1 e2) + vars + r* + w* + inits + (append meta (list (cons 'documentation (syntax->datum docstring)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any)))) + (if tmp-1 + (apply (lambda (k v e1 e2) + (parse-body + req + opt + rest + kw + (cons e1 e2) + vars + r* + w* + inits + (append meta (syntax->datum (map cons k v))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . each-any)))) + (if tmp-1 + (apply (lambda (e1 e2) + (values + meta + req + opt + rest + kw + inits + vars + (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))))) + (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (values '() #f)) tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + '((any any . each-any) . #(each (any any . each-any)))))) + (if tmp-1 + (apply (lambda (args e1 e2 args* e1* e2*) + (call-with-values + (lambda () (get-formals args)) + (lambda (req opt rest kw) + (call-with-values + (lambda () (parse-req req opt rest kw (cons e1 e2))) + (lambda (meta req opt rest kw inits vars body) (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))))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (x y) - (call-with-values - (lambda () (gen-syntax src x r maps ellipsis? mod)) - (lambda (x maps) + (lambda () + (expand-lambda-case + e + r + w + s + mod + get-formals + (map (lambda (tmp-680b775fb37a463-aea + tmp-680b775fb37a463-ae9 + tmp-680b775fb37a463-ae8) + (cons tmp-680b775fb37a463-ae8 + (cons tmp-680b775fb37a463-ae9 tmp-680b775fb37a463-aea))) + e2* + e1* + args*))) + (lambda (meta* else*) + (values + (append meta meta*) + (build-lambda-case s req opt rest kw inits vars body else*))))))))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))) + (strip (lambda (x w) + (if (memq 'top (car 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)) (new (map f old))) + (let lp ((l1 old) (l2 new)) + (cond ((null? l1) x) + ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2))) + (else (list->vector new)))))) + (else x)))))) + (gen-var + (lambda (id) + (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) + (module-gensym (symbol->string id))))) + (lambda-var-list + (lambda (vars) + (let lvl ((vars vars) (ls '()) (w '(()))) + (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) + ((id? vars) (cons (wrap vars w #f) ls)) + ((null? vars) ls) + ((syntax-object? vars) + (lvl (syntax-object-expression vars) + ls + (join-wraps w (syntax-object-wrap vars)))) + (else (cons vars ls))))))) + (global-extend 'local-syntax 'letrec-syntax #t) + (global-extend 'local-syntax 'let-syntax #f) + (global-extend + 'core + 'syntax-parameterize + (lambda (e r w s mod) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp)) + (apply (lambda (var val e1 e2) + (let ((names (map (lambda (x) + (call-with-values + (lambda () (resolve-identifier x w r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(displaced-lexical)) + (syntax-violation + 'syntax-parameterize + "identifier out of context" + e + (source-wrap x w s mod))) + ((memv key '(syntax-parameter)) value) + (else + (syntax-violation + 'syntax-parameterize + "invalid syntax parameter" + e + (source-wrap x w s mod)))))))) + var)) + (bindings + (let ((trans-r (macros-only-env r))) + (map (lambda (x) + (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) + val)))) + (expand-body + (cons e1 e2) + (source-wrap e w s mod) + (extend-env names bindings r) + w + mod))) + tmp) + (syntax-violation + 'syntax-parameterize + "bad syntax" + (source-wrap e w s mod)))))) + (global-extend + 'core + 'quote + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) + (if tmp + (apply (lambda (e) (build-data s (strip e w))) tmp) + (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) + (global-extend + 'core + 'syntax + (letrec* + ((gen-syntax + (lambda (src e r maps ellipsis? mod) + (if (id? e) + (call-with-values + (lambda () (resolve-identifier e '(()) r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(syntax)) + (call-with-values + (lambda () (gen-ref src (car value) (cdr value) maps)) + (lambda (var maps) (values (list 'ref var) maps)))) + ((ellipsis? e r mod) + (syntax-violation 'syntax "misplaced ellipsis" src)) + (else (values (list 'quote e) maps)))))) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) + (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) + (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1)) + (apply (lambda (x dots y) + (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)))))))) + (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) + (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) + (apply (lambda (dots y) + (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)))))))) + tmp) (call-with-values (lambda () (gen-syntax src y r maps ellipsis? mod)) - (lambda (y maps) (values (gen-cons x y) maps)))))) - tmp-1) - (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any))))) - (if tmp - (apply (lambda (e1 e2) - (call-with-values - (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) - (lambda (e maps) (values (gen-vector e) maps)))) - tmp) - (values (list 'quote e) maps)))))))))))) - (gen-ref - (lambda (src var level maps) - (cond ((= level 0) (values var maps)) - ((null? maps) (syntax-violation 'syntax "missing ellipsis" src)) - (else - (call-with-values - (lambda () (gen-ref src var (- 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))))))))))) - (gen-mappend - (lambda (e map-env) - (list 'apply '(primitive append) (gen-map e map-env)))) - (gen-map - (lambda (e map-env) - (let ((formals (map cdr map-env)) - (actuals (map (lambda (x) (list 'ref (car x))) map-env))) - (cond ((eq? (car e) 'ref) (car actuals)) - ((and-map - (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) - (cdr e)) - (cons 'map - (cons (list 'primitive (car e)) - (map (let ((r (map cons formals actuals))) - (lambda (x) (cdr (assq (cadr x) r)))) - (cdr e))))) - (else (cons 'map (cons (list 'lambda formals e) actuals))))))) - (gen-cons - (lambda (x y) - (let ((key (car y))) - (cond ((memv key '(quote)) - (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y)))) - ((eq? (cadr y) '()) (list 'list x)) - (else (list 'cons x y)))) - ((memv key '(list)) (cons 'list (cons x (cdr y)))) - (else (list 'cons x y)))))) - (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y)))) - (gen-vector - (lambda (x) - (cond ((eq? (car x) 'list) (cons 'vector (cdr x))) - ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x)))) - (else (list 'list->vector x))))) - (regen (lambda (x) - (let ((key (car x))) - (cond ((memv key '(ref)) - (build-lexical-reference 'value #f (cadr x) (cadr x))) - ((memv key '(primitive)) (build-primref #f (cadr x))) - ((memv key '(quote)) (build-data #f (cadr x))) - ((memv key '(lambda)) - (if (list? (cadr x)) - (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x))) - (error "how did we get here" x))) - (else (build-primcall #f (car x) (map regen (cdr x))))))))) + (lambda (y maps) + (call-with-values + (lambda () (k maps)) + (lambda (x maps) (values (gen-append x y) maps))))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (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)))))) + tmp-1) + (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any))))) + (if tmp + (apply (lambda (e1 e2) + (call-with-values + (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) + (lambda (e maps) (values (gen-vector e) maps)))) + tmp) + (values (list 'quote e) maps)))))))))))) + (gen-ref + (lambda (src var level maps) + (cond ((= level 0) (values var maps)) + ((null? maps) (syntax-violation 'syntax "missing ellipsis" src)) + (else + (call-with-values + (lambda () (gen-ref src var (- 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))))))))))) + (gen-mappend + (lambda (e map-env) + (list 'apply '(primitive append) (gen-map e map-env)))) + (gen-map + (lambda (e map-env) + (let ((formals (map cdr map-env)) + (actuals (map (lambda (x) (list 'ref (car x))) map-env))) + (cond ((eq? (car e) 'ref) (car actuals)) + ((and-map + (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) + (cdr e)) + (cons 'map + (cons (list 'primitive (car e)) + (map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e))))) + (else (cons 'map (cons (list 'lambda formals e) actuals))))))) + (gen-cons + (lambda (x y) + (let ((key (car y))) + (cond ((memv key '(quote)) + (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y)))) + ((eq? (cadr y) '()) (list 'list x)) + (else (list 'cons x y)))) + ((memv key '(list)) (cons 'list (cons x (cdr y)))) + (else (list 'cons x y)))))) + (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y)))) + (gen-vector + (lambda (x) + (cond ((eq? (car x) 'list) (cons 'vector (cdr x))) + ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x)))) + (else (list 'list->vector x))))) + (regen (lambda (x) + (let ((key (car x))) + (cond ((memv key '(ref)) + (build-lexical-reference 'value #f (cadr x) (cadr x))) + ((memv key '(primitive)) (build-primref #f (cadr x))) + ((memv key '(quote)) (build-data #f (cadr x))) + ((memv key '(lambda)) + (if (list? (cadr x)) + (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x))) + (error "how did we get here" x))) + (else (build-primcall #f (car x) (map regen (cdr x))))))))) + (lambda (e r w s mod) + (let* ((e (source-wrap e w s mod)) + (tmp e) + (tmp ($sc-dispatch tmp '(_ any)))) + (if tmp + (apply (lambda (x) + (call-with-values + (lambda () (gen-syntax e x r '() ellipsis? mod)) + (lambda (e maps) (regen e)))) + tmp) + (syntax-violation 'syntax "bad `syntax' form" e)))))) + (global-extend + 'core + 'lambda (lambda (e r w s mod) - (let* ((e (source-wrap e w s mod)) - (tmp e) - (tmp ($sc-dispatch tmp '(_ any)))) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) (if tmp - (apply (lambda (x) + (apply (lambda (args e1 e2) (call-with-values - (lambda () (gen-syntax e x r '() ellipsis? mod)) - (lambda (e maps) (regen e)))) + (lambda () (lambda-formals args)) + (lambda (req opt rest kw) + (let lp ((body (cons e1 e2)) (meta '())) + (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any)))) + (if (and tmp + (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) + tmp)) + (apply (lambda (docstring e1 e2) + (lp (cons e1 e2) + (append meta (list (cons 'documentation (syntax->datum docstring)))))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any)))) + (if tmp + (apply (lambda (k v e1 e2) + (lp (cons e1 e2) (append meta (syntax->datum (map cons k v))))) + tmp) + (expand-simple-lambda e r w s mod req rest meta body))))))))) tmp) - (syntax-violation 'syntax "bad `syntax' form" e)))))) - (global-extend - 'core - 'lambda - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () (lambda-formals args)) - (lambda (req opt rest kw) - (let lp ((body (cons e1 e2)) (meta '())) - (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any)))) - (if (and tmp - (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) - tmp)) - (apply (lambda (docstring e1 e2) - (lp (cons e1 e2) - (append meta (list (cons 'documentation (syntax->datum docstring)))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any)))) - (if tmp - (apply (lambda (k v e1 e2) - (lp (cons e1 e2) (append meta (syntax->datum (map cons k v))))) - tmp) - (expand-simple-lambda e r w s mod req rest meta body))))))))) - tmp) - (syntax-violation 'lambda "bad lambda" e))))) - (global-extend - 'core - 'lambda* - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () - (expand-lambda-case - e - r - w - s - mod - lambda*-formals - (list (cons args (cons e1 e2))))) - (lambda (meta lcase) (build-case-lambda s meta lcase)))) - tmp) - (syntax-violation 'lambda "bad lambda*" e))))) - (global-extend - 'core - 'case-lambda - (lambda (e r w s mod) - (letrec* - ((build-it - (lambda (meta clauses) - (call-with-values - (lambda () (expand-lambda-case e r w s mod lambda-formals clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))))) - (let* ((tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (syntax-violation 'lambda "bad lambda" e))))) + (global-extend + 'core + 'lambda* + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) (if tmp (apply (lambda (args e1 e2) - (build-it - '() - (map (lambda (tmp-680b775fb37a463-cbc - tmp-680b775fb37a463-cbb - tmp-680b775fb37a463-cba) - (cons tmp-680b775fb37a463-cba - (cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc))) - e2 - e1 - args))) + (call-with-values + (lambda () + (expand-lambda-case + e + r + w + s + mod + lambda*-formals + (list (cons args (cons e1 e2))))) + (lambda (meta lcase) (build-case-lambda s meta lcase)))) tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) - (if (and tmp - (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) - tmp)) - (apply (lambda (docstring args e1 e2) - (build-it - (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-cd2 - tmp-680b775fb37a463-cd1 - tmp-680b775fb37a463-cd0) - (cons tmp-680b775fb37a463-cd0 - (cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2))) - e2 - e1 - args))) - tmp) - (syntax-violation 'case-lambda "bad case-lambda" e)))))))) - (global-extend - 'core - 'case-lambda* - (lambda (e r w s mod) + (syntax-violation 'lambda "bad lambda*" e))))) + (global-extend + 'core + 'case-lambda + (lambda (e r w s mod) + (letrec* + ((build-it + (lambda (meta clauses) + (call-with-values + (lambda () (expand-lambda-case e r w s mod lambda-formals clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))))) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-680b775fb37a463-cb7 + tmp-680b775fb37a463-cb6 + tmp-680b775fb37a463-cb5) + (cons tmp-680b775fb37a463-cb5 + (cons tmp-680b775fb37a463-cb6 tmp-680b775fb37a463-cb7))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (if (and tmp + (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) + tmp)) + (apply (lambda (docstring args e1 e2) + (build-it + (list (cons 'documentation (syntax->datum docstring))) + (map (lambda (tmp-680b775fb37a463-ccd + tmp-680b775fb37a463-ccc + tmp-680b775fb37a463-ccb) + (cons tmp-680b775fb37a463-ccb + (cons tmp-680b775fb37a463-ccc tmp-680b775fb37a463-ccd))) + e2 + e1 + args))) + tmp) + (syntax-violation 'case-lambda "bad case-lambda" e)))))))) + (global-extend + 'core + 'case-lambda* + (lambda (e r w s mod) + (letrec* + ((build-it + (lambda (meta clauses) + (call-with-values + (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))))) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-680b775fb37a463-ced + tmp-680b775fb37a463-cec + tmp-680b775fb37a463-ceb) + (cons tmp-680b775fb37a463-ceb + (cons tmp-680b775fb37a463-cec tmp-680b775fb37a463-ced))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (if (and tmp + (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) + tmp)) + (apply (lambda (docstring args e1 e2) + (build-it + (list (cons 'documentation (syntax->datum docstring))) + (map (lambda (tmp-680b775fb37a463-d03 + tmp-680b775fb37a463-d02 + tmp-680b775fb37a463-d01) + (cons tmp-680b775fb37a463-d01 + (cons tmp-680b775fb37a463-d02 tmp-680b775fb37a463-d03))) + e2 + e1 + args))) + tmp) + (syntax-violation 'case-lambda "bad case-lambda*" e)))))))) + (global-extend + 'core + 'with-ellipsis + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) + (apply (lambda (dots e1 e2) + (let ((id (if (symbol? dots) + '#{ $sc-ellipsis }# + (make-syntax-object + '#{ $sc-ellipsis }# + (syntax-object-wrap dots) + (syntax-object-module dots))))) + (let ((ids (list id)) + (labels (list (gen-label))) + (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-env labels bindings r))) + (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) + tmp) + (syntax-violation + 'with-ellipsis + "bad syntax" + (source-wrap e w s mod)))))) + (global-extend + 'core + 'let (letrec* - ((build-it - (lambda (meta clauses) - (call-with-values - (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))))) - (let* ((tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) - (if tmp - (apply (lambda (args e1 e2) - (build-it - '() - (map (lambda (tmp-680b775fb37a463-cf2 - tmp-680b775fb37a463-cf1 - tmp-680b775fb37a463-cf0) - (cons tmp-680b775fb37a463-cf0 - (cons tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cf2))) - e2 - e1 - args))) + ((expand-let + (lambda (e r w s mod constructor ids vals exps) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'let "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-var-env labels new-vars r))) + (constructor + s + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) vals) + (expand-body exps (source-wrap e nw s mod) nr nw mod)))))))) + (lambda (e r w s mod) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) + (expand-let e r w s mod build-let id val (cons e1 e2))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any)))) + (if (and tmp + (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp)) + (apply (lambda (f id val e1 e2) + (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2))) + tmp) + (syntax-violation 'let "bad let" (source-wrap e w s mod))))))))) + (global-extend + 'core + 'letrec + (lambda (e r w s mod) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) + (let ((ids id)) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec + s + #f + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) val) + (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) - (if (and tmp - (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) - tmp)) - (apply (lambda (docstring args e1 e2) - (build-it - (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-d08 - tmp-680b775fb37a463-d07 - tmp-680b775fb37a463-d06) - (cons tmp-680b775fb37a463-d06 - (cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08))) - e2 - e1 - args))) - tmp) - (syntax-violation 'case-lambda "bad case-lambda*" e)))))))) - (global-extend - 'core - 'with-ellipsis - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) - (apply (lambda (dots e1 e2) - (let ((id (if (symbol? dots) - '#{ $sc-ellipsis }# - (make-syntax-object - '#{ $sc-ellipsis }# - (syntax-object-wrap dots) - (syntax-object-module dots))))) - (let ((ids (list id)) - (labels (list (gen-label))) - (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-env labels bindings r))) - (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) - tmp) - (syntax-violation - 'with-ellipsis - "bad syntax" - (source-wrap e w s mod)))))) - (global-extend - 'core - 'let - (letrec* - ((expand-let - (lambda (e r w s mod constructor ids vals exps) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'let "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-var-env labels new-vars r))) - (constructor - s - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) vals) - (expand-body exps (source-wrap e nw s mod) nr nw mod)))))))) + (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) + (global-extend + 'core + 'letrec* (lambda (e r w s mod) - (let* ((tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any)))) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) (apply (lambda (id val e1 e2) - (expand-let e r w s mod build-let id val (cons e1 e2))) + (let ((ids id)) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec* "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec + s + #t + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) val) + (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) + tmp) + (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) + (global-extend + 'core + 'set! + (lambda (e r w s mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (and tmp (apply (lambda (id val) (id? id)) tmp)) + (apply (lambda (id val) + (call-with-values + (lambda () (resolve-identifier id w r mod #t)) + (lambda (type value id-mod) + (let ((key type)) + (cond ((memv key '(lexical)) + (build-lexical-assignment + s + (syntax->datum id) + value + (expand val r w mod))) + ((memv key '(global)) + (build-global-assignment s value (expand val r w mod) id-mod)) + ((memv key '(macro)) + (if (procedure-property value 'variable-transformer) + (expand (expand-macro value e r w s #f mod) r '(()) mod) + (syntax-violation + 'set! + "not a variable transformer" + (wrap e w mod) + (wrap id w id-mod)))) + ((memv key '(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)))))))) tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any)))) - (if (and tmp - (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp)) - (apply (lambda (f id val e1 e2) - (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2))) + (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any)))) + (if tmp + (apply (lambda (head tail val) + (call-with-values + (lambda () (syntax-type head r '(()) #f #f mod #t)) + (lambda (type value ee* ee ww ss modmod) + (let ((key type)) + (if (memv key '(module-ref)) + (let ((val (expand val r w mod))) + (call-with-values + (lambda () (value (cons head tail) r w mod)) + (lambda (e r w s* mod) + (let* ((tmp-1 e) (tmp (list tmp-1))) + (if (and tmp (apply (lambda (e) (id? e)) tmp)) + (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))) + (build-call + s + (expand + (list '#(syntax-object setter ((top)) (hygiene guile)) head) + r + w + mod) + (map (lambda (e) (expand e r w mod)) (append tail (list val))))))))) tmp) - (syntax-violation 'let "bad let" (source-wrap e w s mod))))))))) - (global-extend - 'core - 'letrec - (lambda (e r w s mod) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) - (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 + (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) + (global-extend + 'module-ref + '@ + (lambda (e r w mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) + (if (and tmp + (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) + (apply (lambda (mod id) + (values + (syntax->datum id) + r + '((top)) + #f + (syntax->datum + (cons '#(syntax-object public ((top)) (hygiene guile)) mod)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))) + (global-extend + 'module-ref + '@@ + (lambda (e r w mod) + (letrec* + ((remodulate + (lambda (x mod) + (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod))) + ((syntax-object? x) + (make-syntax-object + (remodulate (syntax-object-expression x) mod) + (syntax-object-wrap x) + mod)) + ((vector? x) + (let* ((n (vector-length x)) (v (make-vector n))) + (let loop ((i 0)) + (if (= i n) + (begin (if #f #f) v) + (begin + (vector-set! v i (remodulate (vector-ref x i) mod)) + (loop (+ i 1))))))) + (else x))))) + (let* ((tmp e) + (tmp-1 ($sc-dispatch + tmp + '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any)))) + (if (and tmp-1 + (apply (lambda (id) + (and (id? id) + (equal? + (cdr (if (syntax-object? id) (syntax-object-module id) mod)) + '(guile)))) + tmp-1)) + (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) + (if (and tmp-1 + (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1)) + (apply (lambda (mod id) + (values + (syntax->datum id) + r + '((top)) #f - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) val) - (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) - tmp) - (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) - (global-extend - 'core - 'letrec* - (lambda (e r w s mod) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) - (let ((ids id)) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec* "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) - (r (extend-var-env labels new-vars r))) - (build-letrec - s - #t - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) val) - (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) - tmp) - (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) - (global-extend - 'core - 'set! - (lambda (e r w s mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (and tmp (apply (lambda (id val) (id? id)) tmp)) - (apply (lambda (id val) - (call-with-values - (lambda () (resolve-identifier id w r mod #t)) - (lambda (type value id-mod) - (let ((key type)) - (cond ((memv key '(lexical)) - (build-lexical-assignment - s - (syntax->datum id) - value - (expand val r w mod))) - ((memv key '(global)) - (build-global-assignment s value (expand val r w mod) id-mod)) - ((memv key '(macro)) - (if (procedure-property value 'variable-transformer) - (expand (expand-macro value e r w s #f mod) r '(()) mod) - (syntax-violation - 'set! - "not a variable transformer" - (wrap e w mod) - (wrap id w id-mod)))) - ((memv key '(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)))))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any)))) - (if tmp - (apply (lambda (head tail val) - (call-with-values - (lambda () (syntax-type head r '(()) #f #f mod #t)) - (lambda (type value ee* ee ww ss modmod) - (let ((key type)) - (if (memv key '(module-ref)) - (let ((val (expand val r w mod))) - (call-with-values - (lambda () (value (cons head tail) r w mod)) - (lambda (e r w s* mod) - (let* ((tmp-1 e) (tmp (list tmp-1))) - (if (and tmp (apply (lambda (e) (id? e)) tmp)) - (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))) - (build-call - s - (expand - (list '#(syntax-object setter ((top)) (hygiene guile)) head) - r - w - mod) - (map (lambda (e) (expand e r w mod)) (append tail (list val))))))))) - tmp) - (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) - (global-extend - 'module-ref - '@ - (lambda (e r w mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) - (if (and tmp - (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) - (apply (lambda (mod id) - (values - (syntax->datum id) - r - '((top)) - #f - (syntax->datum - (cons '#(syntax-object public ((top)) (hygiene guile)) mod)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) - (global-extend - 'module-ref - '@@ - (lambda (e r w mod) - (letrec* - ((remodulate - (lambda (x mod) - (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod))) - ((syntax-object? x) - (make-syntax-object - (remodulate (syntax-object-expression x) mod) - (syntax-object-wrap x) - mod)) - ((vector? x) - (let* ((n (vector-length x)) (v (make-vector n))) - (let loop ((i 0)) - (if (= i n) - (begin (if #f #f) v) - (begin - (vector-set! v i (remodulate (vector-ref x i) mod)) - (loop (+ i 1))))))) - (else x))))) - (let* ((tmp e) - (tmp-1 ($sc-dispatch - tmp - '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any)))) - (if (and tmp-1 - (apply (lambda (id) - (and (id? id) - (equal? - (cdr (if (syntax-object? id) (syntax-object-module id) mod)) - '(guile)))) - tmp-1)) - (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) + (syntax->datum + (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) + each-any + any)))) + (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) + (apply (lambda (mod exp) + (let ((mod (syntax->datum + (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + (values (remodulate exp mod) r w (source-annotation exp) mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))))) + (global-extend + 'core + 'if + (lambda (e r w s mod) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) + (if tmp-1 + (apply (lambda (test then) + (build-conditional + s + (expand test r w mod) + (expand then r w mod) + (build-void #f))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) - (if (and tmp-1 - (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1)) - (apply (lambda (mod id) - (values - (syntax->datum id) - r - '((top)) - #f - (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + (let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) + (if tmp-1 + (apply (lambda (test then else) + (build-conditional + s + (expand test r w mod) + (expand then r w mod) + (expand else r w mod))) tmp-1) - (let ((tmp-1 ($sc-dispatch - tmp - '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) - each-any - any)))) - (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) - (apply (lambda (mod exp) - (let ((mod (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) - (values (remodulate exp mod) r w (source-annotation exp) mod))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))))) - (global-extend - 'core - 'if - (lambda (e r w s mod) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) - (if tmp-1 - (apply (lambda (test then) - (build-conditional - s - (expand test r w mod) - (expand then r w mod) - (build-void #f))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) - (if tmp-1 - (apply (lambda (test then else) - (build-conditional - s - (expand test r w mod) - (expand then r w mod) - (expand else r w mod))) - tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp))))))) + (global-extend 'begin 'begin '()) + (global-extend 'define 'define '()) + (global-extend 'define-syntax 'define-syntax '()) + (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) + (global-extend 'eval-when 'eval-when '()) + (global-extend + 'core + 'syntax-case + (letrec* + ((convert-pattern + (lambda (pattern keys ellipsis?) + (letrec* + ((cvt* (lambda (p* n ids) + (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) + (if tmp + (apply (lambda (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)))))) + tmp) + (cvt p* n ids))))) + (v-reverse + (lambda (x) + (let loop ((r '()) (x x)) + (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x)))))) + (cvt (lambda (p n ids) + (if (id? p) + (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids)) + ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile))) + (values '_ ids)) + (else (values 'any (cons (cons p n) ids)))) + (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) + (apply (lambda (x dots) + (call-with-values + (lambda () (cvt x (+ n 1) ids)) + (lambda (p ids) + (values (if (eq? p 'any) 'each-any (vector 'each p)) ids)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) + (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1)) + (apply (lambda (x dots ys) + (call-with-values + (lambda () (cvt* ys n ids)) + (lambda (ys ids) + (call-with-values + (lambda () (cvt x (+ n 1) ids)) + (lambda (x ids) + (call-with-values + (lambda () (v-reverse ys)) + (lambda (ys e) (values (vector 'each+ x ys e) ids)))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (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)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (values '() ids)) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) + (if tmp-1 + (apply (lambda (x) + (call-with-values + (lambda () (cvt x n ids)) + (lambda (p ids) (values (vector 'vector p) ids)))) + tmp-1) + (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids)))))))))))))))) + (cvt pattern 0 '())))) + (build-dispatch-call + (lambda (pvars exp y r mod) + (let ((ids (map car pvars)) (levels (map cdr pvars))) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (build-primcall + #f + 'apply + (list (build-simple-lambda + #f + (map syntax->datum ids) + #f + new-vars + '() + (expand + exp + (extend-env + labels + (map (lambda (var level) (cons 'syntax (cons var level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels '(())) + mod)) + y)))))) + (gen-clause + (lambda (x keys clauses r pat fender exp mod) + (call-with-values + (lambda () + (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) + (lambda (p pvars) + (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) + ((not (distinct-bound-ids? (map car pvars))) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + (else + (let ((y (gen-var 'tmp))) + (build-call + #f + (build-simple-lambda + #f + (list 'tmp) + #f + (list y) + '() + (let ((y (build-lexical-reference 'value #f 'tmp y))) + (build-conditional + #f + (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) + (if tmp + (apply (lambda () y) tmp) + (build-conditional + #f + y + (build-dispatch-call pvars fender y r mod) + (build-data #f #f)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) + (list (if (eq? p 'any) + (build-primcall #f 'list (list x)) + (build-primcall #f '$sc-dispatch (list x (build-data #f p))))))))))))) + (gen-syntax-case + (lambda (x keys clauses r mod) + (if (null? clauses) + (build-primcall + #f + 'syntax-violation + (list (build-data #f #f) + (build-data #f "source expression failed to match any pattern") + x)) + (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (pat exp) + (if (and (id? pat) + (and-map + (lambda (x) (not (free-id=? pat x))) + (cons '#(syntax-object ... ((top)) (hygiene guile)) keys))) + (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile))) + (expand exp r '(()) mod) + (let ((labels (list (gen-label))) (var (gen-var pat))) + (build-call + #f + (build-simple-lambda + #f + (list (syntax->datum pat)) + #f + (list var) + '() + (expand + exp + (extend-env labels (list (cons 'syntax (cons var 0))) r) + (make-binding-wrap (list pat) labels '(())) + mod)) + (list x)))) + (gen-clause x keys (cdr clauses) r pat #t exp mod))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(any any any)))) + (if tmp + (apply (lambda (pat fender exp) + (gen-clause x keys (cdr clauses) r pat fender exp mod)) + tmp) + (syntax-violation 'syntax-case "invalid clause" (car clauses)))))))))) + (lambda (e r w s mod) + (let* ((e (source-wrap e w s mod)) + (tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) + (if tmp + (apply (lambda (val key m) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) + (let ((x (gen-var 'tmp))) + (build-call + s + (build-simple-lambda + #f + (list 'tmp) + #f + (list x) + '() + (gen-syntax-case + (build-lexical-reference 'value #f 'tmp x) + key + m + r + mod)) + (list (expand val r '(()) mod)))) + (syntax-violation 'syntax-case "invalid literals list" e))) + tmp) (syntax-violation #f "source expression failed to match any pattern" - tmp))))))) - (global-extend 'begin 'begin '()) - (global-extend 'define 'define '()) - (global-extend 'define-syntax 'define-syntax '()) - (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) - (global-extend 'eval-when 'eval-when '()) - (global-extend - 'core - 'syntax-case + tmp-1)))))) + (set! macroexpand + (lambda* (x #:optional (m 'e) (esew '(eval))) + (expand-top-sequence + (list x) + '() + '((top)) + #f + 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) + (syntax-object-module id)))) + (set! syntax->datum (lambda (x) (strip x '(())))) + (set! syntax-source (lambda (x) (source-annotation x))) + (set! generate-temporaries + (lambda (ls) + (let ((x ls)) + (if (not (list? x)) + (syntax-violation 'generate-temporaries "invalid argument" x))) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls)))) + (set! free-identifier=? + (lambda (x y) + (let ((x x)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'free-identifier=? "invalid argument" x))) + (let ((x y)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'free-identifier=? "invalid argument" x))) + (free-id=? x y))) + (set! bound-identifier=? + (lambda (x y) + (let ((x x)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'bound-identifier=? "invalid argument" x))) + (let ((x y)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'bound-identifier=? "invalid argument" x))) + (bound-id=? x y))) + (set! syntax-violation + (lambda* (who message form #:optional (subform #f)) + (let ((x who)) + (if (not (let ((x x)) (or (not x) (string? x) (symbol? x)))) + (syntax-violation 'syntax-violation "invalid argument" x))) + (let ((x message)) + (if (not (string? x)) + (syntax-violation 'syntax-violation "invalid argument" x))) + (throw 'syntax-error + who + message + (or (source-annotation subform) (source-annotation form)) + (strip form '(())) + (and subform (strip subform '(())))))) (letrec* - ((convert-pattern - (lambda (pattern keys ellipsis?) - (letrec* - ((cvt* (lambda (p* n ids) - (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) - (if tmp - (apply (lambda (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)))))) - tmp) - (cvt p* n ids))))) - (v-reverse - (lambda (x) - (let loop ((r '()) (x x)) - (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x)))))) - (cvt (lambda (p n ids) - (if (id? p) - (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids)) - ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile))) - (values '_ ids)) - (else (values 'any (cons (cons p n) ids)))) - (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) - (apply (lambda (x dots) - (call-with-values - (lambda () (cvt x (+ n 1) ids)) - (lambda (p ids) - (values (if (eq? p 'any) 'each-any (vector 'each p)) ids)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) - (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1)) - (apply (lambda (x dots ys) - (call-with-values - (lambda () (cvt* ys n ids)) - (lambda (ys ids) - (call-with-values - (lambda () (cvt x (+ n 1) ids)) - (lambda (x ids) - (call-with-values - (lambda () (v-reverse ys)) - (lambda (ys e) (values (vector 'each+ x ys e) ids)))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (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)))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (values '() ids)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) - (if tmp-1 - (apply (lambda (x) - (call-with-values - (lambda () (cvt x n ids)) - (lambda (p ids) (values (vector 'vector p) ids)))) - tmp-1) - (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids)))))))))))))))) - (cvt pattern 0 '())))) - (build-dispatch-call - (lambda (pvars exp y r mod) - (let ((ids (map car pvars)) (levels (map cdr pvars))) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-primcall - #f - 'apply - (list (build-simple-lambda - #f - (map syntax->datum ids) - #f - new-vars - '() - (expand - exp - (extend-env - labels - (map (lambda (var level) (cons 'syntax (cons var level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels '(())) - mod)) - y)))))) - (gen-clause - (lambda (x keys clauses r pat fender exp mod) - (call-with-values - (lambda () - (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) - (lambda (p pvars) - (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) - (syntax-violation 'syntax-case "misplaced ellipsis" pat)) - ((not (distinct-bound-ids? (map car pvars))) - (syntax-violation 'syntax-case "duplicate pattern variable" pat)) - (else - (let ((y (gen-var 'tmp))) - (build-call - #f - (build-simple-lambda - #f - (list 'tmp) - #f - (list y) - '() - (let ((y (build-lexical-reference 'value #f 'tmp y))) - (build-conditional - #f - (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) - (if tmp - (apply (lambda () y) tmp) - (build-conditional - #f - y - (build-dispatch-call pvars fender y r mod) - (build-data #f #f)))) - (build-dispatch-call pvars exp y r mod) - (gen-syntax-case x keys clauses r mod)))) - (list (if (eq? p 'any) - (build-primcall #f 'list (list x)) - (build-primcall #f '$sc-dispatch (list x (build-data #f p))))))))))))) - (gen-syntax-case - (lambda (x keys clauses r mod) - (if (null? clauses) - (build-primcall - #f - 'syntax-violation - (list (build-data #f #f) - (build-data #f "source expression failed to match any pattern") - x)) - (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (pat exp) - (if (and (id? pat) - (and-map - (lambda (x) (not (free-id=? pat x))) - (cons '#(syntax-object ... ((top)) (hygiene guile)) keys))) - (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile))) - (expand exp r '(()) mod) - (let ((labels (list (gen-label))) (var (gen-var pat))) - (build-call - #f - (build-simple-lambda - #f - (list (syntax->datum pat)) - #f - (list var) - '() - (expand - exp - (extend-env labels (list (cons 'syntax (cons var 0))) r) - (make-binding-wrap (list pat) labels '(())) - mod)) - (list x)))) - (gen-clause x keys (cdr clauses) r pat #t exp mod))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(any any any)))) - (if tmp - (apply (lambda (pat fender exp) - (gen-clause x keys (cdr clauses) r pat fender exp mod)) - tmp) - (syntax-violation 'syntax-case "invalid clause" (car clauses)))))))))) - (lambda (e r w s mod) - (let* ((e (source-wrap e w s mod)) - (tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) - (if tmp - (apply (lambda (val key m) - (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) - (let ((x (gen-var 'tmp))) - (build-call - s - (build-simple-lambda - #f - (list 'tmp) - #f - (list x) - '() - (gen-syntax-case - (build-lexical-reference 'value #f 'tmp x) - key - m - r - mod)) - (list (expand val r '(()) mod)))) - (syntax-violation 'syntax-case "invalid literals list" e))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))) - (set! macroexpand - (lambda* (x #:optional (m 'e) (esew '(eval))) - (expand-top-sequence - (list x) - '() - '((top)) - #f - 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) - (syntax-object-module id)))) - (set! syntax->datum (lambda (x) (strip x '(())))) - (set! syntax-source (lambda (x) (source-annotation x))) - (set! generate-temporaries - (lambda (ls) - (let ((x ls)) - (if (not (list? x)) - (syntax-violation 'generate-temporaries "invalid argument" x))) - (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls)))) - (set! free-identifier=? - (lambda (x y) - (let ((x x)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'free-identifier=? "invalid argument" x))) - (let ((x y)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'free-identifier=? "invalid argument" x))) - (free-id=? x y))) - (set! bound-identifier=? - (lambda (x y) - (let ((x x)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'bound-identifier=? "invalid argument" x))) - (let ((x y)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'bound-identifier=? "invalid argument" x))) - (bound-id=? x y))) - (set! syntax-violation - (lambda* (who message form #:optional (subform #f)) - (let ((x who)) - (if (not (let ((x x)) (or (not x) (string? x) (symbol? x)))) - (syntax-violation 'syntax-violation "invalid argument" x))) - (let ((x message)) - (if (not (string? x)) - (syntax-violation 'syntax-violation "invalid argument" x))) - (throw 'syntax-error - who - message - (or (source-annotation subform) (source-annotation form)) - (strip form '(())) - (and subform (strip subform '(())))))) - (letrec* - ((%syntax-module - (lambda (id) - (let ((x id)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'syntax-module "invalid argument" x))) - (let ((mod (syntax-object-module id))) - (and (not (equal? mod '(primitive))) (cdr mod))))) - (syntax-local-binding - (lambda* (id - #:key - (resolve-syntax-parameters? #t #:resolve-syntax-parameters?)) - (let ((x id)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'syntax-local-binding "invalid argument" x))) - (with-transformer-environment - (lambda (e r w s rib mod) - (letrec* - ((strip-anti-mark - (lambda (w) - (let ((ms (car w)) (s (cdr w))) - (if (and (pair? ms) (eq? (car ms) #f)) - (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) - (cons ms (if rib (cons rib s) s))))))) - (call-with-values - (lambda () - (resolve-identifier - (syntax-object-expression id) - (strip-anti-mark (syntax-object-wrap id)) - r - (syntax-object-module id) - resolve-syntax-parameters?)) - (lambda (type value mod) - (let ((key type)) - (cond ((memv key '(lexical)) (values 'lexical value)) - ((memv key '(macro)) (values 'macro value)) - ((memv key '(syntax-parameter)) - (values 'syntax-parameter (car value))) - ((memv key '(syntax)) (values 'pattern-variable value)) - ((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) - ((memv key '(global)) - (if (equal? mod '(primitive)) - (values 'primitive value) - (values 'global (cons value (cdr mod))))) - ((memv key '(ellipsis)) - (values - 'ellipsis - (make-syntax-object - (syntax-object-expression value) - (anti-mark (syntax-object-wrap value)) - (syntax-object-module value)))) - (else (values 'other #f))))))))))) - (syntax-locally-bound-identifiers - (lambda (id) - (let ((x id)) - (if (not (nonsymbol-id? x)) - (syntax-violation - 'syntax-locally-bound-identifiers - "invalid argument" - x))) - (locally-bound-identifiers - (syntax-object-wrap id) - (syntax-object-module id))))) - (define! '%syntax-module %syntax-module) - (define! 'syntax-local-binding syntax-local-binding) - (define! - 'syntax-locally-bound-identifiers - syntax-locally-bound-identifiers)) - (letrec* - ((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)))) - (match-each+ - (lambda (e x-pat y-pat z-pat w r mod) - (let f ((e e) (w w)) + ((%syntax-module + (lambda (id) + (let ((x id)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'syntax-module "invalid argument" x))) + (let ((mod (syntax-object-module id))) + (and (not (equal? mod '(primitive))) (cdr mod))))) + (syntax-local-binding + (lambda* (id + #:key + (resolve-syntax-parameters? #t #:resolve-syntax-parameters?)) + (let ((x id)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'syntax-local-binding "invalid argument" x))) + (with-transformer-environment + (lambda (e r w s rib mod) + (letrec* + ((strip-anti-mark + (lambda (w) + (let ((ms (car w)) (s (cdr w))) + (if (and (pair? ms) (eq? (car ms) #f)) + (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) + (cons ms (if rib (cons rib s) s))))))) + (call-with-values + (lambda () + (resolve-identifier + (syntax-object-expression id) + (strip-anti-mark (syntax-object-wrap id)) + r + (syntax-object-module id) + resolve-syntax-parameters?)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(lexical)) (values 'lexical value)) + ((memv key '(macro)) (values 'macro value)) + ((memv key '(syntax-parameter)) + (values 'syntax-parameter (car value))) + ((memv key '(syntax)) (values 'pattern-variable value)) + ((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) + ((memv key '(global)) + (if (equal? mod '(primitive)) + (values 'primitive value) + (values 'global (cons value (cdr mod))))) + ((memv key '(ellipsis)) + (values + 'ellipsis + (make-syntax-object + (syntax-object-expression value) + (anti-mark (syntax-object-wrap value)) + (syntax-object-module value)))) + (else (values 'other #f))))))))))) + (syntax-locally-bound-identifiers + (lambda (id) + (let ((x id)) + (if (not (nonsymbol-id? x)) + (syntax-violation + 'syntax-locally-bound-identifiers + "invalid argument" + x))) + (locally-bound-identifiers + (syntax-object-wrap id) + (syntax-object-module id))))) + (define! '%syntax-module %syntax-module) + (define! 'syntax-local-binding syntax-local-binding) + (define! + 'syntax-locally-bound-identifiers + syntax-locally-bound-identifiers)) + (letrec* + ((match-each + (lambda (e p w mod) (cond ((pair? e) - (call-with-values - (lambda () (f (cdr e) w)) - (lambda (xr* y-pat r) - (if r - (if (null? y-pat) - (let ((xr (match (car e) x-pat w '() mod))) - (if xr (values (cons xr xr*) y-pat r) (values #f #f #f))) - (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod))) - (values #f #f #f))))) + (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) - (f (syntax-object-expression e) - (join-wraps w (syntax-object-wrap e)))) - (else (values '() y-pat (match e z-pat w r mod))))))) - (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)))) - (match-empty - (lambda (p r) - (cond ((null? p) r) - ((eq? p '_) r) - ((eq? p 'any) (cons '() r)) - ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) - ((eq? p 'each-any) (cons '() r)) - (else - (let ((key (vector-ref p 0))) - (cond ((memv key '(each)) (match-empty (vector-ref p 1) r)) - ((memv key '(each+)) - (match-empty - (vector-ref p 1) + (match-each + (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + (syntax-object-module e))) + (else #f)))) + (match-each+ + (lambda (e x-pat y-pat z-pat w r mod) + (let f ((e e) (w w)) + (cond ((pair? e) + (call-with-values + (lambda () (f (cdr e) w)) + (lambda (xr* y-pat r) + (if r + (if (null? y-pat) + (let ((xr (match (car e) x-pat w '() mod))) + (if xr (values (cons xr xr*) y-pat r) (values #f #f #f))) + (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod))) + (values #f #f #f))))) + ((syntax-object? e) + (f (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)))) + (else (values '() y-pat (match e z-pat w r mod))))))) + (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)))) + (match-empty + (lambda (p r) + (cond ((null? p) r) + ((eq? p '_) r) + ((eq? p 'any) (cons '() r)) + ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) + ((eq? p 'each-any) (cons '() r)) + (else + (let ((key (vector-ref p 0))) + (cond ((memv key '(each)) (match-empty (vector-ref p 1) r)) + ((memv key '(each+)) (match-empty - (reverse (vector-ref p 2)) - (match-empty (vector-ref p 3) r)))) - ((memv key '(free-id atom)) r) - ((memv key '(vector)) (match-empty (vector-ref p 1) r)))))))) - (combine - (lambda (r* r) - (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r))))) - (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 - (let ((key (vector-ref p 0))) - (cond ((memv key '(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))))))))) - ((memv key '(each+)) - (call-with-values - (lambda () - (match-each+ - e - (vector-ref p 1) - (vector-ref p 2) - (vector-ref p 3) - w - r - mod)) - (lambda (xr* y-pat r) - (and r - (null? y-pat) - (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) - ((memv key '(free-id)) - (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) - ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r)) - ((memv key '(vector)) - (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) - (match (lambda (e p w r mod) - (cond ((not r) #f) - ((eq? p '_) r) - ((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)) - ((eq? p '_) '()) - ((syntax-object? e) - (match* - (syntax-object-expression e) - p - (syntax-object-wrap e) - '() - (syntax-object-module e))) - (else (match* e p '(()) '() #f))))))) + (vector-ref p 1) + (match-empty + (reverse (vector-ref p 2)) + (match-empty (vector-ref p 3) r)))) + ((memv key '(free-id atom)) r) + ((memv key '(vector)) (match-empty (vector-ref p 1) r)))))))) + (combine + (lambda (r* r) + (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r))))) + (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 + (let ((key (vector-ref p 0))) + (cond ((memv key '(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))))))))) + ((memv key '(each+)) + (call-with-values + (lambda () + (match-each+ + e + (vector-ref p 1) + (vector-ref p 2) + (vector-ref p 3) + w + r + mod)) + (lambda (xr* y-pat r) + (and r + (null? y-pat) + (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) + ((memv key '(free-id)) + (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) + ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r)) + ((memv key '(vector)) + (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) + (match (lambda (e p w r mod) + (cond ((not r) #f) + ((eq? p '_) r) + ((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)) + ((eq? p '_) '()) + ((syntax-object? e) + (match* + (syntax-object-expression e) + p + (syntax-object-wrap e) + '() + (syntax-object-module e))) + (else (match* e p '(()) '() #f)))))))) (define with-syntax (make-syntax-transformer @@ -2806,11 +2814,9 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-115b - tmp-680b775fb37a463-115a - tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-115a) - tmp-680b775fb37a463-115b)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2826,9 +2832,11 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) + (map (lambda (tmp-680b775fb37a463-116f + tmp-680b775fb37a463-116e + tmp-680b775fb37a463-116d) + (list (cons tmp-680b775fb37a463-116d tmp-680b775fb37a463-116e) + tmp-680b775fb37a463-116f)) template pattern keyword))) @@ -2843,11 +2851,9 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-118d - tmp-680b775fb37a463-118c - tmp-680b775fb37a463-118b) - (list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c) - tmp-680b775fb37a463-118d)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2863,11 +2869,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-11ac - tmp-680b775fb37a463-11ab - tmp-680b775fb37a463-11aa) - (list (cons tmp-680b775fb37a463-11aa tmp-680b775fb37a463-11ab) - tmp-680b775fb37a463-11ac)) + (map (lambda (tmp-680b775fb37a463-11a7 + tmp-680b775fb37a463-11a6 + tmp-680b775fb37a463-11a5) + (list (cons tmp-680b775fb37a463-11a5 tmp-680b775fb37a463-11a6) + tmp-680b775fb37a463-11a7)) template pattern keyword))) @@ -3007,8 +3013,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463) - (list "value" tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-120f) + (list "value" tmp-680b775fb37a463-120f)) p) (quasi q lev)) (quasicons @@ -3063,8 +3069,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-122f) - (list "value" tmp-680b775fb37a463-122f)) + (map (lambda (tmp-680b775fb37a463-122a) + (list "value" tmp-680b775fb37a463-122a)) p) (vquasi q lev)) (quasicons @@ -3082,7 +3088,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-122f) + (list "value" tmp-680b775fb37a463-122f)) p) (vquasi q lev)) (quasicons @@ -3171,8 +3178,7 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-127d) - (cons "vector" t-680b775fb37a463-127d)) + (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3207,9 +3213,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12a7) + (apply (lambda (t-680b775fb37a463-12a2) (cons '#(syntax-object list ((top)) (hygiene guile)) - t-680b775fb37a463-12a7)) + t-680b775fb37a463-12a2)) tmp) (syntax-violation #f @@ -3225,10 +3231,10 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-12bb t-680b775fb37a463-12ba) + (apply (lambda (t-680b775fb37a463-12b6 t-680b775fb37a463-12b5) (list '#(syntax-object cons ((top)) (hygiene guile)) - t-680b775fb37a463-12bb - t-680b775fb37a463-12ba)) + t-680b775fb37a463-12b6 + t-680b775fb37a463-12b5)) tmp) (syntax-violation #f @@ -3241,9 +3247,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12c7) + (apply (lambda (t-680b775fb37a463-12c2) (cons '#(syntax-object append ((top)) (hygiene guile)) - t-680b775fb37a463-12c7)) + t-680b775fb37a463-12c2)) tmp) (syntax-violation #f @@ -3256,9 +3262,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12d3) + (apply (lambda (t-680b775fb37a463-12ce) (cons '#(syntax-object vector ((top)) (hygiene guile)) - t-680b775fb37a463-12d3)) + t-680b775fb37a463-12ce)) tmp) (syntax-violation #f @@ -3269,9 +3275,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463-12df tmp)) + (let ((t-680b775fb37a463-12da tmp)) (list '#(syntax-object list->vector ((top)) (hygiene guile)) - t-680b775fb37a463-12df)))) + t-680b775fb37a463-12da)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 567f6065b..678d08b97 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -165,7 +165,12 @@ (eval-when (compile) (set-current-module (resolve-module '(guile)))) -(let () +(let ((syntax? (module-ref (current-module) 'syntax?)) + (make-syntax (module-ref (current-module) 'make-syntax)) + (syntax-expression (module-ref (current-module) 'syntax-expression)) + (syntax-wrap (module-ref (current-module) 'syntax-wrap)) + (syntax-module (module-ref (current-module) 'syntax-module))) + (define-syntax define-expansion-constructors (lambda (x) (syntax-case x () @@ -466,7 +471,25 @@ ;; 'gensym' so that the generated identifier is reproducible. (module-gensym (symbol->string id))) - (define-structure (syntax-object expression wrap module)) + (define (syntax-object? x) + (or (syntax? x) + (and (vector? x) + (= (vector-length x) 4) + (eqv? (vector-ref x 0) 'syntax-object)))) + (define (make-syntax-object expression wrap module) + (vector 'syntax-object expression wrap module)) + (define (syntax-object-expression obj) + (if (syntax? obj) + (syntax-expression obj) + (vector-ref obj 1))) + (define (syntax-object-wrap obj) + (if (syntax? obj) + (syntax-wrap obj) + (vector-ref obj 2))) + (define (syntax-object-module obj) + (if (syntax? obj) + (syntax-module obj) + (vector-ref obj 3))) (define-syntax no-source (identifier-syntax #f)) |