summaryrefslogtreecommitdiff
path: root/module/ice-9/psyntax-pp.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/psyntax-pp.scm')
-rw-r--r--module/ice-9/psyntax-pp.scm3494
1 files changed, 3494 insertions, 0 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
new file mode 100644
index 000000000..151bf8e5b
--- /dev/null
+++ b/module/ice-9/psyntax-pp.scm
@@ -0,0 +1,3494 @@
+(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
+(if #f #f)
+
+(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/simple (vector-ref %expanded-vtables 0) src)))
+ (make-const
+ (lambda (src exp)
+ (make-struct/simple (vector-ref %expanded-vtables 1) src exp)))
+ (make-primitive-ref
+ (lambda (src name)
+ (make-struct/simple (vector-ref %expanded-vtables 2) src name)))
+ (make-lexical-ref
+ (lambda (src name gensym)
+ (make-struct/simple (vector-ref %expanded-vtables 3) src name gensym)))
+ (make-lexical-set
+ (lambda (src name gensym exp)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 4)
+ src
+ name
+ gensym
+ exp)))
+ (make-module-ref
+ (lambda (src mod name public?)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 5)
+ src
+ mod
+ name
+ public?)))
+ (make-module-set
+ (lambda (src mod name public? exp)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 6)
+ src
+ mod
+ name
+ public?
+ exp)))
+ (make-toplevel-ref
+ (lambda (src name)
+ (make-struct/simple (vector-ref %expanded-vtables 7) src name)))
+ (make-toplevel-set
+ (lambda (src name exp)
+ (make-struct/simple (vector-ref %expanded-vtables 8) src name exp)))
+ (make-toplevel-define
+ (lambda (src name exp)
+ (make-struct/simple (vector-ref %expanded-vtables 9) src name exp)))
+ (make-conditional
+ (lambda (src test consequent alternate)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 10)
+ src
+ test
+ consequent
+ alternate)))
+ (make-call
+ (lambda (src proc args)
+ (make-struct/simple (vector-ref %expanded-vtables 11) src proc args)))
+ (make-primcall
+ (lambda (src name args)
+ (make-struct/simple (vector-ref %expanded-vtables 12) src name args)))
+ (make-seq
+ (lambda (src head tail)
+ (make-struct/simple (vector-ref %expanded-vtables 13) src head tail)))
+ (make-lambda
+ (lambda (src meta body)
+ (make-struct/simple (vector-ref %expanded-vtables 14) src meta body)))
+ (make-lambda-case
+ (lambda (src req opt rest kw inits gensyms body alternate)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 15)
+ src
+ req
+ opt
+ rest
+ kw
+ inits
+ gensyms
+ body
+ alternate)))
+ (make-let
+ (lambda (src names gensyms vals body)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 16)
+ src
+ names
+ gensyms
+ vals
+ body)))
+ (make-letrec
+ (lambda (src in-order? names gensyms vals body)
+ (make-struct/simple
+ (vector-ref %expanded-vtables 17)
+ 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)))))
+ (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)))))
+ (source-annotation
+ (lambda (x)
+ (let ((props (source-properties (if (syntax? x) (syntax-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)
+ (module-define!
+ (current-module)
+ sym
+ (make-syntax-transformer sym type val))))
+ (nonsymbol-id?
+ (lambda (x) (and (syntax? x) (symbol? (syntax-expression x)))))
+ (id? (lambda (x)
+ (if (symbol? x) #t (and (syntax? x) (symbol? (syntax-expression x))))))
+ (id-sym-name&marks
+ (lambda (x w)
+ (if (syntax? x)
+ (values
+ (syntax-expression x)
+ (join-marks (car w) (car (syntax-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-expression id) (ribcage-symnames ribcage)))
+ (set-ribcage-marks!
+ ribcage
+ (cons (car (syntax-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)))
+ (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? id)
+ (let ((id (syntax-expression id))
+ (w1 (syntax-wrap id))
+ (mod (syntax-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-global
+ (lambda (var mod)
+ (if (and (not mod) (current-module))
+ (warn "module system is booted, we should have a module" var))
+ (let ((v (and (not (equal? mod '(primitive)))
+ (module-variable
+ (if mod (resolve-module (cdr mod)) (current-module))
+ var))))
+ (if (and v (variable-bound? v) (macro? (variable-ref v)))
+ (let* ((m (variable-ref v))
+ (type (macro-type m))
+ (trans (macro-binding m))
+ (trans (if (pair? trans) (car trans) trans)))
+ (if (eq? type 'syntax-parameter)
+ (if resolve-syntax-parameters?
+ (let ((lexical (assq-ref r v)))
+ (values 'macro (if lexical (cdr lexical) trans) mod))
+ (values type v mod))
+ (values type trans mod)))
+ (values 'global var mod)))))
+ (resolve-lexical
+ (lambda (label mod)
+ (let ((b (assq-ref r label)))
+ (if b
+ (let ((type (car b)) (value (cdr b)))
+ (if (eq? type 'syntax-parameter)
+ (if resolve-syntax-parameters?
+ (values 'macro value mod)
+ (values type label mod))
+ (values type value mod)))
+ (values 'displaced-lexical #f #f))))))
+ (let ((n (id-var-name id w mod)))
+ (cond ((syntax? n)
+ (if (not (eq? n id))
+ (resolve-identifier n w r mod resolve-syntax-parameters?)
+ (resolve-identifier
+ (syntax-expression n)
+ (syntax-wrap n)
+ r
+ (syntax-module n)
+ resolve-syntax-parameters?)))
+ ((symbol? n)
+ (resolve-global n (if (syntax? id) (syntax-module id) mod)))
+ ((string? n)
+ (resolve-lexical n (if (syntax? id) (syntax-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? i) (syntax-module i)))
+ (mj (and (syntax? j) (syntax-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? x) (syntax-expression x) x))))))
+ (cond ((syntax? ni) (free-id=? ni j))
+ ((syntax? nj) (free-id=? i nj))
+ ((symbol? ni)
+ (and (eq? nj (let ((x j)) (if (syntax? x) (syntax-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? i) (syntax? j))
+ (and (eq? (syntax-expression i) (syntax-expression j))
+ (same-marks? (car (syntax-wrap i)) (car (syntax-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? x)
+ (make-syntax
+ (syntax-expression x)
+ (join-wraps w (syntax-wrap x))
+ (syntax-module x)))
+ ((null? x) x)
+ (else (make-syntax 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-module id) (wrap var '((top)) mod))))))
+ (macro-introduced-identifier?
+ (lambda (id) (not (equal? (car (syntax-wrap id)) '(top)))))
+ (fresh-derived-name
+ (lambda (id orig-form)
+ (symbol-append
+ (syntax-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-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-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 (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
+ (list (build-data #f name)
+ (build-data
+ #f
+ (if (eq? type 'define-syntax-parameter-form)
+ 'syntax-parameter
+ '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 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 (make-syntax '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)
+ (list (make-syntax '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? e)
+ (syntax-type
+ (syntax-expression e)
+ r
+ (join-wraps w (syntax-wrap e))
+ (or (source-annotation e) s)
+ rib
+ (or (syntax-module e) mod)
+ for-car?))
+ ((self-evaluating? e) (values 'constant #f e e w s mod))
+ (else (values 'other #f e e w s mod)))))
+ (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? 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? value) (syntax-expression value) value)
+ (if (syntax? value) (syntax-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? x)
+ (let ((w (syntax-wrap x)))
+ (let ((ms (car w)) (ss (cdr w)))
+ (if (and (pair? ms) (eq? (car ms) #f))
+ (make-syntax
+ (syntax-expression x)
+ (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
+ (syntax-module x))
+ (make-syntax
+ (decorate-source (syntax-expression x) s)
+ (cons (cons m ms)
+ (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
+ (syntax-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-7b8 transformer-environment)
+ (t-680b775fb37a463-7b9 (lambda (k) (k e r w s rib mod))))
+ (with-fluid*
+ t-680b775fb37a463-7b8
+ t-680b775fb37a463-7b9
+ (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)
+ (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
+ (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))
+ (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 '#{ $sc-ellipsis }# (syntax-wrap e) (syntax-module e))
+ '(())
+ r
+ mod
+ #f))
+ (lambda (type value mod)
+ (if (eq? type 'ellipsis)
+ (bound-id=? e value)
+ (free-id=? e (make-syntax '... '((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
+ (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))
+ #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-aa9
+ tmp-680b775fb37a463-aa8
+ tmp-680b775fb37a463-aa7)
+ (cons tmp-680b775fb37a463-aa7
+ (cons tmp-680b775fb37a463-aa8 tmp-680b775fb37a463-aa9)))
+ 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? x) (strip (syntax-expression x) (syntax-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? id) (syntax-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? vars)
+ (lvl (syntax-expression vars) ls (join-wraps w (syntax-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 'syntax-parameter
+ (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)
+ (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* ((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))))))
+ (if tmp
+ (apply (lambda (args e1 e2)
+ (build-it
+ '()
+ (map (lambda (tmp-680b775fb37a463-c76
+ tmp-680b775fb37a463-c75
+ tmp-680b775fb37a463-c74)
+ (cons tmp-680b775fb37a463-c74
+ (cons tmp-680b775fb37a463-c75 tmp-680b775fb37a463-c76)))
+ 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-c8c
+ tmp-680b775fb37a463-c8b
+ tmp-680b775fb37a463-c8a)
+ (cons tmp-680b775fb37a463-c8a
+ (cons tmp-680b775fb37a463-c8b tmp-680b775fb37a463-c8c)))
+ 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-cac
+ tmp-680b775fb37a463-cab
+ tmp-680b775fb37a463-caa)
+ (cons tmp-680b775fb37a463-caa
+ (cons tmp-680b775fb37a463-cab tmp-680b775fb37a463-cac)))
+ 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-cc2
+ tmp-680b775fb37a463-cc1
+ tmp-680b775fb37a463-cc0)
+ (cons tmp-680b775fb37a463-cc0
+ (cons tmp-680b775fb37a463-cc1 tmp-680b775fb37a463-cc2)))
+ 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
+ '#{ $sc-ellipsis }#
+ (syntax-wrap dots)
+ (syntax-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))))))))
+ (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)
+ (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 (make-syntax '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 (make-syntax '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? x)
+ (make-syntax
+ (remodulate (syntax-expression x) mod)
+ (syntax-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
+ (list '_
+ (vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile)))
+ 'any))))
+ (if (and tmp-1
+ (apply (lambda (id)
+ (and (id? id)
+ (equal? (cdr (if (syntax? id) (syntax-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
+ (syntax->datum
+ (cons (make-syntax 'private '((top)) '(hygiene guile)) mod))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ (list '_
+ (vector 'free-id (make-syntax '@@ '((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 (make-syntax '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 (make-syntax '_ '((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 (make-syntax '... '((top)) '(hygiene guile)) keys)))
+ (if (free-id=? pat (make-syntax '_ '((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 datum (syntax-wrap id) (syntax-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-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-expression id)
+ (strip-anti-mark (syntax-wrap id))
+ r
+ (syntax-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 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
+ (syntax-expression value)
+ (anti-mark (syntax-wrap value))
+ (syntax-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-wrap id) (syntax-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? e)
+ (match-each
+ (syntax-expression e)
+ p
+ (join-wraps w (syntax-wrap e))
+ (syntax-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? e)
+ (f (syntax-expression e) (join-wraps w (syntax-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? e)
+ (match-each-any
+ (syntax-expression e)
+ (join-wraps w (syntax-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-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? e)
+ (match*
+ (syntax-expression e)
+ p
+ (join-wraps w (syntax-wrap e))
+ r
+ (syntax-module e)))
+ (else (match* e p w r mod))))))
+ (set! $sc-dispatch
+ (lambda (e p)
+ (cond ((eq? p 'any) (list e))
+ ((eq? p '_) '())
+ ((syntax? e)
+ (match*
+ (syntax-expression e)
+ p
+ (syntax-wrap e)
+ '()
+ (syntax-module e)))
+ (else (match* e p '(()) '() #f))))))))
+
+(define with-syntax
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'with-syntax
+ 'macro
+ (lambda (x)
+ (let ((tmp x))
+ (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
+ (if tmp-1
+ (apply (lambda (e1 e2)
+ (cons (make-syntax 'let '((top)) '(hygiene guile))
+ (cons '() (cons e1 e2))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
+ (if tmp-1
+ (apply (lambda (out in e1 e2)
+ (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
+ in
+ '()
+ (list out
+ (cons (make-syntax 'let '((top)) '(hygiene guile))
+ (cons '() (cons e1 e2))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
+ (if tmp-1
+ (apply (lambda (out in e1 e2)
+ (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
+ (cons (make-syntax 'list '((top)) '(hygiene guile)) in)
+ '()
+ (list out
+ (cons (make-syntax 'let '((top)) '(hygiene guile))
+ (cons '() (cons e1 e2))))))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))))))
+
+(define syntax-error
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'syntax-error
+ 'macro
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+ (if (if tmp
+ (apply (lambda (keyword operands message arg)
+ (string? (syntax->datum message)))
+ tmp)
+ #f)
+ (apply (lambda (keyword operands message arg)
+ (syntax-violation
+ (syntax->datum keyword)
+ (string-join
+ (cons (syntax->datum message)
+ (map (lambda (x) (object->string (syntax->datum x))) arg)))
+ (if (syntax->datum keyword) (cons keyword operands) #f)))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any))))
+ (if (if tmp
+ (apply (lambda (message arg) (string? (syntax->datum message))) tmp)
+ #f)
+ (apply (lambda (message arg)
+ (cons (make-syntax
+ 'syntax-error
+ (list '(top)
+ (vector
+ 'ribcage
+ '#(syntax-error)
+ '#((top))
+ (vector
+ (cons '(hygiene guile)
+ (make-syntax 'syntax-error '((top)) '(hygiene guile))))))
+ '(hygiene guile))
+ (cons '(#f) (cons message arg))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))
+
+(define syntax-rules
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'syntax-rules
+ 'macro
+ (lambda (xx)
+ (letrec*
+ ((expand-clause
+ (lambda (clause)
+ (let ((tmp-1 clause))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ (list '(any . any)
+ (cons (vector
+ 'free-id
+ (make-syntax 'syntax-error '((top)) '(hygiene guile)))
+ '(any . each-any))))))
+ (if (if tmp
+ (apply (lambda (keyword pattern message arg)
+ (string? (syntax->datum message)))
+ tmp)
+ #f)
+ (apply (lambda (keyword pattern message arg)
+ (list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
+ (list (make-syntax 'syntax '((top)) '(hygiene guile))
+ (cons (make-syntax 'syntax-error '((top)) '(hygiene guile))
+ (cons (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
+ (cons message arg))))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
+ (if tmp
+ (apply (lambda (keyword pattern template)
+ (list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
+ (list (make-syntax 'syntax '((top)) '(hygiene guile)) template)))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
+ (expand-syntax-rules
+ (lambda (dots keys docstrings clauses)
+ (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses))))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ '(each-any each-any #(each ((any . any) any)) each-any))))
+ (if tmp
+ (apply (lambda (k docstring keyword pattern template clause)
+ (let ((tmp (cons (make-syntax 'lambda '((top)) '(hygiene guile))
+ (cons (list (make-syntax 'x '((top)) '(hygiene guile)))
+ (append
+ docstring
+ (list (vector
+ (cons (make-syntax 'macro-type '((top)) '(hygiene guile))
+ (make-syntax
+ 'syntax-rules
+ (list '(top)
+ (vector
+ 'ribcage
+ '#(syntax-rules)
+ '#((top))
+ (vector
+ (cons '(hygiene guile)
+ (make-syntax
+ 'syntax-rules
+ '((top))
+ '(hygiene guile))))))
+ '(hygiene guile)))
+ (cons (make-syntax 'patterns '((top)) '(hygiene guile))
+ pattern))
+ (cons (make-syntax 'syntax-case '((top)) '(hygiene guile))
+ (cons (make-syntax 'x '((top)) '(hygiene guile))
+ (cons k clause)))))))))
+ (let ((form tmp))
+ (if dots
+ (let ((tmp dots))
+ (let ((dots tmp))
+ (list (make-syntax 'with-ellipsis '((top)) '(hygiene guile))
+ dots
+ form)))
+ form))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ (let ((tmp xx))
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any))))))
+ (if tmp-1
+ (apply (lambda (k keyword pattern template)
+ (expand-syntax-rules
+ #f
+ k
+ '()
+ (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (k docstring keyword pattern template)
+ (string? (syntax->datum docstring)))
+ tmp-1)
+ #f)
+ (apply (lambda (k docstring keyword pattern template)
+ (expand-syntax-rules
+ #f
+ k
+ (list docstring)
+ (map (lambda (tmp-680b775fb37a463
+ tmp-680b775fb37a463-112f
+ tmp-680b775fb37a463-112e)
+ (list (cons tmp-680b775fb37a463-112e tmp-680b775fb37a463-112f)
+ tmp-680b775fb37a463))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (dots k keyword pattern template) (identifier? dots))
+ tmp-1)
+ #f)
+ (apply (lambda (dots k keyword pattern template)
+ (expand-syntax-rules
+ dots
+ k
+ '()
+ (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any))))))
+ (if (if tmp-1
+ (apply (lambda (dots k docstring keyword pattern template)
+ (if (identifier? dots) (string? (syntax->datum docstring)) #f))
+ tmp-1)
+ #f)
+ (apply (lambda (dots k docstring keyword pattern template)
+ (expand-syntax-rules
+ dots
+ k
+ (list docstring)
+ (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-2))
+ template
+ pattern
+ keyword)))
+ tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp)))))))))))))))
+
+(define define-syntax-rule
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'define-syntax-rule
+ 'macro
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
+ (if tmp
+ (apply (lambda (name pattern template)
+ (list (make-syntax 'define-syntax '((top)) '(hygiene guile))
+ name
+ (list (make-syntax 'syntax-rules '((top)) '(hygiene guile))
+ '()
+ (list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern)
+ template))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
+ (if (if tmp
+ (apply (lambda (name pattern docstring template)
+ (string? (syntax->datum docstring)))
+ tmp)
+ #f)
+ (apply (lambda (name pattern docstring template)
+ (list (make-syntax 'define-syntax '((top)) '(hygiene guile))
+ name
+ (list (make-syntax 'syntax-rules '((top)) '(hygiene guile))
+ '()
+ docstring
+ (list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern)
+ template))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))
+
+(define let*
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'let*
+ 'macro
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any))))
+ (if (if tmp
+ (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
+ #f)
+ (apply (lambda (let* x v e1 e2)
+ (let f ((bindings (map list x v)))
+ (if (null? bindings)
+ (cons (make-syntax 'let '((top)) '(hygiene guile))
+ (cons '() (cons e1 e2)))
+ (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (body binding)
+ (list (make-syntax 'let '((top)) '(hygiene guile))
+ (list binding)
+ body))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
+
+(define quasiquote
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'quasiquote
+ 'macro
+ (letrec*
+ ((quasi (lambda (p lev)
+ (let ((tmp p))
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ (list (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile)))
+ 'any))))
+ (if tmp-1
+ (apply (lambda (p)
+ (if (= lev 0)
+ (list "value" p)
+ (quasicons
+ (list "quote" (make-syntax 'unquote '((top)) '(hygiene guile)))
+ (quasi (list p) (- lev 1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch
+ tmp
+ (list (vector
+ 'free-id
+ (make-syntax
+ 'quasiquote
+ (list '(top)
+ (vector
+ 'ribcage
+ '#(quasiquote)
+ '#((top))
+ (vector
+ (cons '(hygiene guile)
+ (make-syntax 'quasiquote '((top)) '(hygiene guile))))))
+ '(hygiene guile)))
+ 'any))))
+ (if tmp-1
+ (apply (lambda (p)
+ (quasicons
+ (list "quote"
+ (make-syntax
+ 'quasiquote
+ (list '(top)
+ (vector
+ 'ribcage
+ '#(quasiquote)
+ '#((top))
+ (vector
+ (cons '(hygiene guile)
+ (make-syntax 'quasiquote '((top)) '(hygiene guile))))))
+ '(hygiene guile)))
+ (quasi (list p) (+ lev 1))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (p q)
+ (let ((tmp-1 p))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ (cons (vector
+ 'free-id
+ (make-syntax 'unquote '((top)) '(hygiene guile)))
+ 'each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasilist*
+ (map (lambda (tmp-680b775fb37a463-11d3)
+ (list "value" tmp-680b775fb37a463-11d3))
+ p)
+ (quasi q lev))
+ (quasicons
+ (quasicons
+ (list "quote"
+ (make-syntax 'unquote '((top)) '(hygiene guile)))
+ (quasi p (- lev 1)))
+ (quasi q lev))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ (cons (vector
+ 'free-id
+ (make-syntax
+ 'unquote-splicing
+ '((top))
+ '(hygiene guile)))
+ 'each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasiappend
+ (map (lambda (tmp-680b775fb37a463-11d8)
+ (list "value" tmp-680b775fb37a463-11d8))
+ p)
+ (quasi q lev))
+ (quasicons
+ (quasicons
+ (list "quote"
+ (make-syntax
+ 'unquote-splicing
+ '((top))
+ '(hygiene guile)))
+ (quasi p (- lev 1)))
+ (quasi q lev))))
+ tmp)
+ (quasicons (quasi p lev) (quasi q lev))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
+ (if tmp-1
+ (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1)
+ (let ((p tmp)) (list "quote" p)))))))))))))
+ (vquasi
+ (lambda (p lev)
+ (let ((tmp p))
+ (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply (lambda (p q)
+ (let ((tmp-1 p))
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ (cons (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile)))
+ 'each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasilist*
+ (map (lambda (tmp-680b775fb37a463-11ee)
+ (list "value" tmp-680b775fb37a463-11ee))
+ p)
+ (vquasi q lev))
+ (quasicons
+ (quasicons
+ (list "quote" (make-syntax 'unquote '((top)) '(hygiene guile)))
+ (quasi p (- lev 1)))
+ (vquasi q lev))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ (cons (vector
+ 'free-id
+ (make-syntax 'unquote-splicing '((top)) '(hygiene guile)))
+ 'each-any))))
+ (if tmp
+ (apply (lambda (p)
+ (if (= lev 0)
+ (quasiappend
+ (map (lambda (tmp-680b775fb37a463-11f3)
+ (list "value" tmp-680b775fb37a463-11f3))
+ p)
+ (vquasi q lev))
+ (quasicons
+ (quasicons
+ (list "quote"
+ (make-syntax 'unquote-splicing '((top)) '(hygiene guile)))
+ (quasi p (- lev 1)))
+ (vquasi q lev))))
+ tmp)
+ (quasicons (quasi p lev) (vquasi q lev))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply (lambda () '("quote" ())) tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp))))))))
+ (quasicons
+ (lambda (x y)
+ (let ((tmp-1 (list x y)))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (x y)
+ (let ((tmp y))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
+ (if tmp-1
+ (apply (lambda (dy)
+ (let ((tmp x))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any))))
+ (if tmp
+ (apply (lambda (dx) (list "quote" (cons dx dy))) tmp)
+ (if (null? dy) (list "list" x) (list "list*" x y))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any))))
+ (if tmp-1
+ (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1)
+ (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any))))
+ (if tmp
+ (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp)
+ (list "list*" x y)))))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ (quasiappend
+ (lambda (x y)
+ (let ((tmp y))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
+ (if tmp
+ (apply (lambda ()
+ (if (null? x)
+ '("quote" ())
+ (if (null? (cdr x))
+ (car x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (p) (cons "append" p)) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ tmp)
+ (if (null? x)
+ y
+ (let ((tmp-1 (list x y)))
+ (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
+ (if tmp
+ (apply (lambda (p y) (cons "append" (append p (list y)))) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))
+ (quasilist*
+ (lambda (x y)
+ (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
+ (quasivector
+ (lambda (x)
+ (let ((tmp x))
+ (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
+ (if tmp
+ (apply (lambda (x) (list "quote" (list->vector x))) tmp)
+ (let f ((y x)
+ (k (lambda (ls)
+ (let ((tmp-1 ls))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t-680b775fb37a463-123c)
+ (cons "vector" t-680b775fb37a463-123c))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ (let ((tmp y))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
+ (if tmp-1
+ (apply (lambda (y)
+ (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
+ y)))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
+ (if tmp-1
+ (apply (lambda (y) (k y)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
+ (if tmp-1
+ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
+ (let ((else tmp))
+ (let ((tmp x))
+ (let ((t-680b775fb37a463 tmp))
+ (list "list->vector" t-680b775fb37a463)))))))))))))))))
+ (emit (lambda (x)
+ (let ((tmp x))
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
+ (if tmp-1
+ (apply (lambda (x) (list (make-syntax 'quote '((top)) '(hygiene guile)) x))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t-680b775fb37a463)
+ (cons (make-syntax 'list '((top)) '(hygiene guile))
+ t-680b775fb37a463))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
+ (if tmp-1
+ (apply (lambda (x y)
+ (let f ((x* x))
+ (if (null? x*)
+ (emit y)
+ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (t-680b775fb37a463-127a t-680b775fb37a463)
+ (list (make-syntax 'cons '((top)) '(hygiene guile))
+ t-680b775fb37a463-127a
+ t-680b775fb37a463))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t-680b775fb37a463)
+ (cons (make-syntax 'append '((top)) '(hygiene guile))
+ t-680b775fb37a463))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp-1 (map emit x)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (t-680b775fb37a463)
+ (cons (make-syntax 'vector '((top)) '(hygiene guile))
+ t-680b775fb37a463))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any))))
+ (if tmp-1
+ (apply (lambda (x)
+ (let ((tmp (emit x)))
+ (let ((t-680b775fb37a463-129e tmp))
+ (list (make-syntax 'list->vector '((top)) '(hygiene guile))
+ t-680b775fb37a463-129e))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
+ (if tmp-1
+ (apply (lambda (x) x) tmp-1)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp)))))))))))))))))))
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+ (if tmp
+ (apply (lambda (e) (emit (quasi e 0))) tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1)))))))))
+
+(define include
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'include
+ 'macro
+ (lambda (x)
+ (letrec*
+ ((read-file
+ (lambda (fn dir k)
+ (let ((p (open-input-file
+ (if (absolute-file-name? fn)
+ fn
+ (if dir
+ (in-vicinity dir fn)
+ (syntax-violation
+ 'include
+ "relative file name only allowed when the include form is in a file"
+ x))))))
+ (let ((enc (file-encoding p)))
+ (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
+ (let f ((x (read p)) (result '()))
+ (if (eof-object? x)
+ (begin (close-port p) (reverse result))
+ (f (read p) (cons (datum->syntax k x) result)))))))))
+ (let ((src (syntax-source x)))
+ (let ((file (if src (assq-ref src 'filename) #f)))
+ (let ((dir (if (string? file) (dirname file) #f)))
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (k filename)
+ (let ((fn (syntax->datum filename)))
+ (let ((tmp-1 (read-file fn dir filename)))
+ (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+ (if tmp
+ (apply (lambda (exp)
+ (cons (make-syntax 'begin '((top)) '(hygiene guile)) exp))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))))
+
+(define include-from-path
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'include-from-path
+ 'macro
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(any any))))
+ (if tmp
+ (apply (lambda (k filename)
+ (let ((fn (syntax->datum filename)))
+ (let ((tmp (datum->syntax
+ filename
+ (canonicalize-path
+ (let ((t (%search-load-path fn)))
+ (if t
+ t
+ (syntax-violation
+ 'include-from-path
+ "file not found in path"
+ x
+ filename)))))))
+ (let ((fn tmp))
+ (list (make-syntax 'include '((top)) '(hygiene guile)) fn)))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))
+
+(define unquote
+ (make-syntax-transformer
+ 'unquote
+ 'macro
+ (lambda (x)
+ (syntax-violation
+ 'unquote
+ "expression not valid outside of quasiquote"
+ x))))
+
+(define unquote-splicing
+ (make-syntax-transformer
+ 'unquote-splicing
+ 'macro
+ (lambda (x)
+ (syntax-violation
+ 'unquote-splicing
+ "expression not valid outside of quasiquote"
+ x))))
+
+(define make-variable-transformer
+ (lambda (proc)
+ (if (procedure? proc)
+ (let ((trans (lambda (x) (proc x))))
+ (set-procedure-property! trans 'variable-transformer #t)
+ trans)
+ (error "variable transformer not a procedure" proc))))
+
+(define identifier-syntax
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'identifier-syntax
+ 'macro
+ (lambda (xx)
+ (let ((tmp-1 xx))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+ (if tmp
+ (apply (lambda (e)
+ (list (make-syntax 'lambda '((top)) '(hygiene guile))
+ (list (make-syntax 'x '((top)) '(hygiene guile)))
+ (vector
+ (cons (make-syntax 'macro-type '((top)) '(hygiene guile))
+ (make-syntax
+ 'identifier-syntax
+ (list '(top)
+ (vector
+ 'ribcage
+ '#(identifier-syntax)
+ '#((top))
+ (vector
+ (cons '(hygiene guile)
+ (make-syntax 'identifier-syntax '((top)) '(hygiene guile))))))
+ '(hygiene guile))))
+ (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
+ (make-syntax 'x '((top)) '(hygiene guile))
+ '()
+ (list (make-syntax 'id '((top)) '(hygiene guile))
+ (list (make-syntax 'identifier? '((top)) '(hygiene guile))
+ (list (make-syntax 'syntax '((top)) '(hygiene guile))
+ (make-syntax 'id '((top)) '(hygiene guile))))
+ (list (make-syntax 'syntax '((top)) '(hygiene guile)) e))
+ (list (list (make-syntax '_ '((top)) '(hygiene guile))
+ (make-syntax 'x '((top)) '(hygiene guile))
+ (make-syntax '... '((top)) '(hygiene guile)))
+ (list (make-syntax 'syntax '((top)) '(hygiene guile))
+ (cons e
+ (list (make-syntax 'x '((top)) '(hygiene guile))
+ (make-syntax '... '((top)) '(hygiene guile)))))))))
+ tmp)
+ (let ((tmp ($sc-dispatch
+ tmp-1
+ (list '_
+ '(any any)
+ (list (list (vector 'free-id (make-syntax 'set! '((top)) '(hygiene guile)))
+ 'any
+ 'any)
+ 'any)))))
+ (if (if tmp
+ (apply (lambda (id exp1 var val exp2)
+ (if (identifier? id) (identifier? var) #f))
+ tmp)
+ #f)
+ (apply (lambda (id exp1 var val exp2)
+ (list (make-syntax 'make-variable-transformer '((top)) '(hygiene guile))
+ (list (make-syntax 'lambda '((top)) '(hygiene guile))
+ (list (make-syntax 'x '((top)) '(hygiene guile)))
+ (vector
+ (cons (make-syntax 'macro-type '((top)) '(hygiene guile))
+ (make-syntax 'variable-transformer '((top)) '(hygiene guile))))
+ (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
+ (make-syntax 'x '((top)) '(hygiene guile))
+ (list (make-syntax 'set! '((top)) '(hygiene guile)))
+ (list (list (make-syntax 'set! '((top)) '(hygiene guile)) var val)
+ (list (make-syntax 'syntax '((top)) '(hygiene guile)) exp2))
+ (list (cons id
+ (list (make-syntax 'x '((top)) '(hygiene guile))
+ (make-syntax '... '((top)) '(hygiene guile))))
+ (list (make-syntax 'syntax '((top)) '(hygiene guile))
+ (cons exp1
+ (list (make-syntax 'x '((top)) '(hygiene guile))
+ (make-syntax '... '((top)) '(hygiene guile))))))
+ (list id
+ (list (make-syntax 'identifier? '((top)) '(hygiene guile))
+ (list (make-syntax 'syntax '((top)) '(hygiene guile)) id))
+ (list (make-syntax 'syntax '((top)) '(hygiene guile)) exp1))))))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))
+
+(define define*
+ (let ((make-syntax make-syntax))
+ (make-syntax-transformer
+ 'define*
+ 'macro
+ (lambda (x)
+ (let ((tmp-1 x))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
+ (if tmp
+ (apply (lambda (id args b0 b1)
+ (list (make-syntax 'define '((top)) '(hygiene guile))
+ id
+ (cons (make-syntax 'lambda* '((top)) '(hygiene guile))
+ (cons args (cons b0 b1)))))
+ tmp)
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
+ (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
+ (apply (lambda (id val)
+ (list (make-syntax 'define '((top)) '(hygiene guile)) id val))
+ tmp)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-1))))))))))
+