diff options
Diffstat (limited to 'module/ice-9/psyntax-pp.scm')
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 3494 |
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)))))))))) + |