[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/02: Regenerate psyntax-pp.scm
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/02: Regenerate psyntax-pp.scm |
|
Date: |
Tue, 20 Feb 2024 08:16:41 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit 2717773bb1ee2d2ae7a0111de21e4f183e5ce86d
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Feb 20 13:56:22 2024 +0100
Regenerate psyntax-pp.scm
* module/ice-9/psyntax-pp.scm (syntax?): Regenerate. With the modified
pretty-printer, things are a bit different.
---
module/ice-9/psyntax-pp.scm | 6240 ++++++++++++++++++++-----------------------
1 file changed, 2864 insertions(+), 3376 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index bc1719ad3..58c9c403a 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -7,3597 +7,3085 @@
(syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module))
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
- (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 mod name)
- (make-struct/simple (vector-ref %expanded-vtables 7) src mod name)))
- (make-toplevel-set
- (lambda (src mod name exp)
- (make-struct/simple
- (vector-ref %expanded-vtables 8)
- src
- mod
- name
- exp)))
- (make-toplevel-define
- (lambda (src mod name exp)
- (make-struct/simple
- (vector-ref %expanded-vtables 9)
- src
- mod
- 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)))))
- (sourcev-filename (lambda (s) (vector-ref s 0)))
- (sourcev-line (lambda (s) (vector-ref s 1)))
- (sourcev-column (lambda (s) (vector-ref s 2)))
- (sourcev->alist
- (lambda (sourcev)
- (letrec*
- ((maybe-acons (lambda (k v tail) (if v (acons k v tail) tail))))
- (and sourcev
- (maybe-acons
- 'filename
- (sourcev-filename sourcev)
- (list (cons 'line (sourcev-line sourcev))
- (cons 'column (sourcev-column sourcev))))))))
- (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 (sourcev) (make-void sourcev)))
- (build-call
- (lambda (sourcev fun-exp arg-exps)
- (make-call sourcev fun-exp arg-exps)))
- (build-conditional
- (lambda (sourcev test-exp then-exp else-exp)
- (make-conditional sourcev test-exp then-exp else-exp)))
- (build-lexical-reference
- (lambda (type sourcev name var) (make-lexical-ref sourcev name var)))
- (build-lexical-assignment
- (lambda (sourcev name var exp)
- (maybe-name-value! name exp)
- (make-lexical-set sourcev name var exp)))
- (analyze-variable
- (lambda (mod var modref-cont bare-cont)
- (if (not mod)
- (bare-cont #f var)
- (let ((kind (car mod)) (mod (cdr mod)))
- (let ((key kind))
- (cond ((memv key '(public)) (modref-cont mod var #t))
- ((memv key '(private))
- (if (equal? mod (module-name (current-module)))
- (bare-cont mod var)
- (modref-cont mod var #f)))
- ((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 mod 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 (sourcev var mod)
- (analyze-variable
- mod
- var
- (lambda (mod var public?) (make-module-ref sourcev mod var public?))
- (lambda (mod var) (make-toplevel-ref sourcev mod var)))))
- (build-global-assignment
- (lambda (sourcev var exp mod)
- (maybe-name-value! var exp)
- (analyze-variable
- mod
- var
- (lambda (mod var public?)
- (make-module-set sourcev mod var public? exp))
- (lambda (mod var) (make-toplevel-set sourcev mod var exp)))))
- (build-global-definition
- (lambda (sourcev mod var exp)
- (maybe-name-value! var exp)
- (make-toplevel-define sourcev (and mod (cdr mod)) 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)))))
- (datum-sourcev
- (lambda (datum)
- (let ((props (source-properties datum)))
- (and (pair? props)
- (vector
- (assq-ref props 'filename)
- (assq-ref props 'line)
- (assq-ref props 'column))))))
- (source-annotation
- (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x))))
- (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)
- (rlabels (ribcage-labels ribcage))
- (rmarks (ribcage-marks ribcage)))
- (cond ((null? symnames) (search sym (cdr subst) marks mod))
- ((and (eq? (car symnames) sym) (same-marks? marks (car
rmarks)))
- (let ((n (car rlabels)))
- (if (pair? n)
- (if (equal? mod (car n))
- (values (cdr n) marks)
- (f (cdr symnames) (cdr rlabels) (cdr rmarks)))
- (values n marks))))
- (else (f (cdr symnames) (cdr rlabels) (cdr
rmarks)))))))
- (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 (or (syntax-module id) mod)))
- (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)))
+ (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 mod name) (make-struct/simple (vector-ref
%expanded-vtables 7) src mod name)))
+ (make-toplevel-set
+ (lambda (src mod name exp) (make-struct/simple (vector-ref
%expanded-vtables 8) src mod name exp)))
+ (make-toplevel-define
+ (lambda (src mod name exp) (make-struct/simple (vector-ref
%expanded-vtables 9) src mod 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)))))
+ (sourcev-filename (lambda (s) (vector-ref s 0)))
+ (sourcev-line (lambda (s) (vector-ref s 1)))
+ (sourcev-column (lambda (s) (vector-ref s 2)))
+ (sourcev->alist
+ (lambda (sourcev)
+ (letrec* ((maybe-acons (lambda (k v tail) (if v (acons k v
tail) tail))))
+ (and sourcev
+ (maybe-acons
+ 'filename
+ (sourcev-filename sourcev)
+ (list (cons 'line (sourcev-line sourcev)) (cons 'column
(sourcev-column sourcev))))))))
+ (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 (sourcev) (make-void sourcev)))
+ (build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev
fun-exp arg-exps)))
+ (build-conditional
+ (lambda (sourcev test-exp then-exp else-exp) (make-conditional
sourcev test-exp then-exp else-exp)))
+ (build-lexical-reference (lambda (type sourcev name var)
(make-lexical-ref sourcev name var)))
+ (build-lexical-assignment
+ (lambda (sourcev name var exp) (maybe-name-value! name exp)
(make-lexical-set sourcev name var exp)))
+ (analyze-variable
+ (lambda (mod var modref-cont bare-cont)
+ (if (not mod)
+ (bare-cont #f var)
+ (let ((kind (car mod)) (mod (cdr mod)))
+ (let ((key kind))
+ (cond
+ ((memv key '(public)) (modref-cont mod var #t))
+ ((memv key '(private))
+ (if (equal? mod (module-name (current-module)))
(bare-cont mod var) (modref-cont mod var #f)))
+ ((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 mod 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 (sourcev var mod)
+ (analyze-variable
+ mod
+ var
+ (lambda (mod var public?) (make-module-ref sourcev mod var
public?))
+ (lambda (mod var) (make-toplevel-ref sourcev mod var)))))
+ (build-global-assignment
+ (lambda (sourcev var exp mod)
+ (maybe-name-value! var exp)
+ (analyze-variable
+ mod
+ var
+ (lambda (mod var public?) (make-module-set sourcev mod var
public? exp))
+ (lambda (mod var) (make-toplevel-set sourcev mod var exp)))))
+ (build-global-definition
+ (lambda (sourcev mod var exp)
+ (maybe-name-value! var exp)
+ (make-toplevel-define sourcev (and mod (cdr mod)) 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)))))
+ (datum-sourcev
+ (lambda (datum)
+ (let ((props (source-properties datum)))
+ (and (pair? props) (vector (assq-ref props 'filename)
(assq-ref props 'line) (assq-ref props 'column))))))
+ (source-annotation (lambda (x) (if (syntax? x) (syntax-sourcev x)
(datum-sourcev x))))
+ (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)
+ (rlabels (ribcage-labels ribcage))
+ (rmarks (ribcage-marks ribcage)))
+ (cond
+ ((null? symnames) (search sym (cdr subst)
marks mod))
+ ((and (eq? (car symnames) sym) (same-marks?
marks (car rmarks)))
+ (let ((n (car rlabels)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (cdr rlabels)
(cdr rmarks)))
+ (values n marks))))
+ (else (f (cdr symnames) (cdr rlabels) (cdr
rmarks)))))))
+ (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 (or (syntax-module id) mod)))
+ (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
+ (or (syntax-module n) mod)
+ resolve-syntax-parameters?)))
+ ((symbol? n) (resolve-global n (or (and (syntax? id)
(syntax-module id)) mod)))
+ ((string? n) (resolve-lexical n (or (and (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))
- 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
- (or (syntax-module n) mod)
- resolve-syntax-parameters?)))
- ((symbol? n)
- (resolve-global n (or (and (syntax? id) (syntax-module
id)) mod)))
- ((string? n)
- (resolve-lexical n (or (and (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) (source-wrap x w #f defmod)))
- (wrap-syntax
- (lambda (x w defmod)
- (make-syntax
- (syntax-expression x)
- w
- (or (syntax-module x) defmod)
- (syntax-sourcev x))))
- (source-wrap
- (lambda (x w s defmod)
- (cond ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x)
- ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))
defmod))
- ((null? x) x)
- (else (make-syntax x w defmod s)))))
- (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 (or (syntax-module id) mod) (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
mod 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
mod var (build-void s))
- mod))
- (lambda ()
(build-global-definition s mod 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 mod 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 mod var type (expand e r w mod)))))
- (else '())))
- ((memv key '(c&e))
- (let ((e (expand-install-global
mod 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 mod 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 (mod name type e)
- (build-global-definition
- #f
- mod
- 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)))
+ (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) (source-wrap x w #f defmod)))
+ (wrap-syntax
+ (lambda (x w defmod)
+ (make-syntax (syntax-expression x) w (or (syntax-module x)
defmod) (syntax-sourcev x))))
+ (source-wrap
+ (lambda (x w s defmod)
+ (cond
+ ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x)
+ ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))
defmod))
+ ((null? x) x)
+ (else (make-syntax x w defmod s)))))
+ (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 (or
(syntax-module id) mod) (wrap var '((top)) mod))))))
+ (macro-introduced-identifier? (lambda (id) (not
(equal? (car (syntax-wrap id)) '(top)))))
+ (ensure-fresh-name
+ (lambda (var)
+ (letrec* ((ribcage-has-var?
+ (lambda (var)
+ (let lp ((labels (ribcage-labels
ribcage)))
+ (and (pair? labels)
+ (let ((wrapped (cdar
labels)))
+ (or (eq?
(syntax-expression wrapped) var) (lp (cdr labels)))))))))
+ (let lp ((unique var) (n 1))
+ (if (ribcage-has-var? unique)
+ (let ((tail (string->symbol
(number->string n))))
+ (lp (symbol-append var '- tail)
(#{1+}# n)))
+ unique)))))
+ (fresh-derived-name
+ (lambda (id orig-form)
+ (ensure-fresh-name
+ (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 mod 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 mod var (build-void s))
+ mod))
+ (lambda ()
+
(build-global-definition s mod 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 mod 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 mod var type (expand e r w mod)))))
+ (else '())))
+ ((memv key '(c&e))
+ (let ((e (expand-install-global
mod 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 mod 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 (mod name type e)
+ (build-global-definition
+ #f
+ mod
+ 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 () (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
fs) 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
+ (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
fs) 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)
(source-wrap
- (cons (make-syntax 'lambda
'((top)) '(hygiene guile))
- (wrap (cons args
(cons e1 e2)) w mod))
- '(())
- s
- #f)
+ (cons (make-syntax 'lambda
'((top)) '(hygiene guile))
+ (wrap (cons args
(cons e1 e2)) w mod))
+ '(())
+ s
+ #f)
'(())
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
+ 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
+ e
+ r
+ w
+ s
+ mod))
+ ((memv key '(global-call))
+ (expand-call
+ (build-global-reference
(or (source-annotation (car e)) s)
(if (syntax? value) (syntax-expression value) value)
(or (and (syntax? value) (syntax-module value)) mod))
- e
- r
- w
- s
- mod))
- ((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 e)))
- ((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*
- ((decorate-source (lambda (x) (source-wrap x '(()) s #f)))
- (map* (lambda (f x)
- (cond ((null? x) x)
- ((pair? x) (cons (f (car x)) (map* f (cdr x))))
- (else (f x)))))
- (rebuild-macro-output
- (lambda (x m)
- (cond ((pair? x)
- (decorate-source (map* (lambda (x)
(rebuild-macro-output x m)) x)))
- ((syntax? x)
- (let ((w (syntax-wrap x)))
- (let ((ms (car w)) (ss (cdr w)))
- (if (and (pair? ms) (eq? (car ms) #f))
- (wrap-syntax
- x
- (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr
ss)))
- mod)
- (wrap-syntax
- x
- (cons (cons m ms)
- (if rib (cons rib (cons 'shift ss)) (cons
'shift ss)))
- mod)))))
- ((vector? x)
- (let* ((n (vector-length x)) (v (make-vector n)))
- (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)))))
- (decorate-source v)))
- ((symbol? x)
- (syntax-violation
- #f
- "encountered raw symbol in macro output"
- (source-wrap e w (cdr w) mod)
- x))
- (else (decorate-source x))))))
- (let* ((t-680b775fb37a463-de8 transformer-environment)
- (t-680b775fb37a463-de9 (lambda (k) (k e r w s rib mod))))
- (with-fluid*
- t-680b775fb37a463-de8
- t-680b775fb37a463-de9
- (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 '())
- (expand-tail-expr #f))
- (cond ((null? body)
- (if (not expand-tail-expr)
- (begin
- (if (null? ids) (syntax-violation #f "empty body"
outer-form))
- (syntax-violation #f "body should end with an
expression" outer-form)))
- (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)))
- (let ((src (source-annotation outer-form)))
- (let lp ((var-ids var-ids) (vars vars) (vals vals) (tail
(expand-tail-expr)))
- (cond ((null? var-ids) tail)
- ((not (car var-ids))
- (lp (cdr var-ids)
- (cdr vars)
- (cdr vals)
- (make-seq src ((car vals)) tail)))
- (else
- (let ((var-ids
- (map (lambda (id) (if id (syntax->datum
id) '_)) (reverse var-ids)))
- (vars (map (lambda (var) (or var
(gen-label))) (reverse vars)))
- (vals (map (lambda (expand-expr id)
- (if id (expand-expr)
(make-seq src (expand-expr) (build-void src))))
- (reverse vals)
- (reverse var-ids))))
- (build-letrec src #t var-ids vars vals
tail)))))))
- (expand-tail-expr
- (parse body
- ids
- labels
- (cons #f var-ids)
- (cons #f vars)
- (cons expand-tail-expr vals)
- bindings
- #f))
- (else
- (let ((e (cdar body)) (er (caar body)) (body (cdr body)))
- (call-with-values
- (lambda ()
- (syntax-type e er '(()) (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)))
+ 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 e)))
+ ((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* ((decorate-source (lambda (x) (source-wrap x '(()) s
#f)))
+ (map* (lambda (f x)
+ (cond ((null? x) x) ((pair? x) (cons (f (car
x)) (map* f (cdr x)))) (else (f x)))))
+ (rebuild-macro-output
+ (lambda (x m)
+ (cond
+ ((pair? x) (decorate-source (map* (lambda (x)
(rebuild-macro-output x m)) x)))
+ ((syntax? x)
+ (let ((w (syntax-wrap x)))
+ (let ((ms (car w)) (ss (cdr w)))
+ (if (and (pair? ms) (eq? (car ms) #f))
+ (wrap-syntax x (cons (cdr ms) (if rib
(cons rib (cdr ss)) (cdr ss))) mod)
+ (wrap-syntax
+ x
+ (cons (cons m ms) (if rib (cons rib
(cons 'shift ss)) (cons 'shift ss)))
+ mod)))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector
n)))
+ (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)))))
+ (decorate-source v)))
+ ((symbol? x)
+ (syntax-violation
+ #f
+ "encountered raw symbol in macro output"
+ (source-wrap e w (cdr w) mod)
+ x))
+ (else (decorate-source x))))))
+ (let* ((t-680b775fb37a463-e04 transformer-environment)
+ (t-680b775fb37a463-e05 (lambda (k) (k e r w s rib
mod))))
+ (with-fluid*
+ t-680b775fb37a463-e04
+ t-680b775fb37a463-e05
+ (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 '())
+ (expand-tail-expr #f))
+ (cond
+ ((null? body)
+ (if (not expand-tail-expr)
+ (begin
+ (if (null? ids) (syntax-violation #f "empty body"
outer-form))
+ (syntax-violation #f "body should end with an
expression" outer-form)))
+ (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)))
+ (let ((src (source-annotation outer-form)))
+ (let lp ((var-ids var-ids) (vars vars) (vals vals)
(tail (expand-tail-expr)))
+ (cond
+ ((null? var-ids) tail)
+ ((not (car var-ids))
+ (lp (cdr var-ids) (cdr vars) (cdr vals) (make-seq
src ((car vals)) tail)))
+ (else (let ((var-ids (map (lambda (id) (if id
(syntax->datum id) '_)) (reverse var-ids)))
+ (vars (map (lambda (var) (or var
(gen-label))) (reverse vars)))
+ (vals (map (lambda (expand-expr id)
+ (if id (expand-expr)
(make-seq src (expand-expr) (build-void src))))
+ (reverse vals)
+ (reverse var-ids))))
+ (build-letrec src #t var-ids vars vals
tail)))))))
+ (expand-tail-expr
+ (parse body ids labels (cons #f var-ids) (cons #f vars)
(cons expand-tail-expr vals) bindings #f))
+ (else (let ((e (cdar body)) (er (caar body)) (body (cdr
body)))
+ (call-with-values
+ (lambda () (syntax-type e er '(())
(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 body
+ (cons id ids)
+ (cons label labels)
+ (cons id var-ids)
+ (cons var vars)
+ (cons (let ((wrapped
(source-wrap e w s mod)))
+ (lambda () (expand
wrapped er '(()) mod)))
+ vals)
+ (cons (cons 'lexical var)
bindings)
+ #f))))
+ ((memv key '(define-syntax-form))
+ (let ((id (wrap value w mod)) (label
(gen-label)) (trans-r (macros-only-env er)))
(extend-ribcage! ribcage id label)
- (parse body
- (cons id ids)
- (cons label labels)
- (cons id var-ids)
- (cons var vars)
- (cons (let ((wrapped
(source-wrap e w s mod)))
- (lambda () (expand
wrapped er '(()) mod)))
- vals)
- (cons (cons 'lexical var)
bindings)
- #f))))
- ((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
+ (set-cdr!
+ r
+ (extend-env
(list label)
(list (cons 'macro
(eval-local-transformer (expand e trans-r w mod) mod)))
(cdr r)))
- (parse body (cons id ids) labels var-ids
vars vals bindings #f)))
- ((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
+ (parse body (cons id ids) labels
var-ids vars vals bindings #f)))
+ ((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 body (cons id ids) labels var-ids
vars vals bindings #f)))
- ((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)
- body
- (cons (cons er
(wrap (car forms) w mod)) (f (cdr forms)))))
- ids
- labels
- var-ids
- vars
- vals
- bindings
- #f))
- 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)
- body
- (cons (cons er (wrap (car
forms) w mod)) (f (cdr forms)))))
- ids
- labels
- var-ids
- vars
- vals
- bindings
- #f))))
- (else
- (let ((wrapped (source-wrap e w s mod)))
- (parse body
- ids
- labels
- var-ids
- vars
- vals
- bindings
- (lambda () (expand wrapped er
'(()) mod))))))))))))))))
- (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)
- (or (syntax-module e) mod)
- #f)
- '(())
- 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
+ (parse body (cons id ids) labels
var-ids vars vals bindings #f)))
+ ((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)
+ body
+ (cons (cons
er (wrap (car forms) w mod))
+ (f (cdr
forms)))))
+ ids
+ labels
+ var-ids
+ vars
+ vals
+ bindings
+ #f))
+ 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)
+ body
+ (cons (cons er (wrap (car
forms) w mod)) (f (cdr forms)))))
+ ids
+ labels
+ var-ids
+ vars
+ vals
+ bindings
+ #f))))
+ (else (let ((wrapped (source-wrap e w s
mod)))
+ (parse body
+ ids
+ labels
+ var-ids
+ vars
+ vals
+ bindings
+ (lambda () (expand wrapped
er '(()) mod))))))))))))))))
+ (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) (or
(syntax-module e) mod) #f)
+ '(())
+ 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
- (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
+ (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
- 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-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463
- (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
- 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)
- (letrec*
- ((annotate
- (lambda (proc datum)
- (let ((s (proc x)))
- (if (and s (supports-source-properties? datum))
- (set-source-properties! datum (sourcev->alist s)))
- datum))))
- (cond ((syntax? x) (annotate syntax-sourcev (strip
(syntax-expression x))))
- ((pair? x) (cons (strip (car x)) (strip (cdr x))))
- ((vector? x) (list->vector (strip (vector->list x))))
- (else x)))))
- (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)))))))
+ (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-2
+
tmp-680b775fb37a463-1
+
tmp-680b775fb37a463)
+ (cons
tmp-680b775fb37a463
+ (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ 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)
+ (letrec* ((annotate
+ (lambda (proc datum)
+ (let ((s (proc x)))
+ (if (and s (supports-source-properties?
datum))
+ (set-source-properties! datum
(sourcev->alist s)))
+ datum))))
+ (cond
+ ((syntax? x) (annotate syntax-sourcev (strip
(syntax-expression x))))
+ ((pair? x) (cons (strip (car x)) (strip (cdr x))))
+ ((vector? x) (list->vector (strip (vector->list x))))
+ (else x)))))
+ (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
+ '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
+ (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
+ 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)))
+ (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))))))
+ (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))) tmp)
- (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
+ '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))) tmp)
+ (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
(global-extend
- 'core
- 'quote-syntax
- (lambda (e r w s mod)
- (let* ((tmp-1 (source-wrap e w s mod)) (tmp ($sc-dispatch tmp-1 '(_
any))))
- (if tmp
- (apply (lambda (e) (build-data s e)) tmp)
- (let ((e tmp-1)) (syntax-violation 'quote "bad syntax" e))))))
+ 'core
+ 'quote-syntax
+ (lambda (e r w s mod)
+ (let* ((tmp-1 (source-wrap e w s mod)) (tmp ($sc-dispatch tmp-1 '(_
any))))
+ (if tmp (apply (lambda (e) (build-data s e)) tmp) (let ((e tmp-1))
(syntax-violation 'quote "bad syntax" e))))))
(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)
+ '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 () (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-1 ($sc-dispatch tmp '#(vector (any .
each-any)))))
- (if tmp-1
- (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-1)
- (let ((tmp-1 (list tmp)))
- (if (and tmp-1 (apply (lambda (x) (eq?
(syntax->datum x) #nil)) tmp-1))
- (apply (lambda (x) (values ''#nil maps))
tmp-1)
- (let ((tmp ($sc-dispatch tmp '())))
- (if tmp
- (apply (lambda () (values ''() 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))))))
+ (lambda () (gen-syntax
src y r maps ellipsis? mod))
+ (lambda (y maps) (values
(gen-cons x y) maps))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp
'#(vector (any . each-any)))))
+ (if tmp-1
+ (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-1)
+ (let ((tmp-1 (list tmp)))
+ (if (and tmp-1 (apply (lambda
(x) (eq? (syntax->datum x) #nil)) tmp-1))
+ (apply (lambda (x) (values
''#nil maps)) tmp-1)
+ (let ((tmp ($sc-dispatch
tmp '())))
+ (if tmp
+ (apply (lambda ()
(values ''() 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
+ '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)))))
+ (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)))))
+ '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)))))
+ 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
+ '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-6c3
- tmp-680b775fb37a463-6c2
- tmp-680b775fb37a463-6c1)
- (cons tmp-680b775fb37a463-6c1
- (cons tmp-680b775fb37a463-6c2
tmp-680b775fb37a463-6c3)))
+ (map (lambda (tmp-680b775fb37a463-6c3
tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c1)
+ (cons tmp-680b775fb37a463-6c1 (cons
tmp-680b775fb37a463-6c2 tmp-680b775fb37a463-6c3)))
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-6d9
- tmp-680b775fb37a463-6d8
- tmp-680b775fb37a463-6d7)
- (cons tmp-680b775fb37a463-6d7
- (cons tmp-680b775fb37a463-6d8
tmp-680b775fb37a463-6d9)))
- e2
- e1
- args)))
- tmp)
- (syntax-violation 'case-lambda "bad case-lambda" e))))))))
+ 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-6d9
tmp-680b775fb37a463-6d8 tmp-680b775fb37a463-6d7)
+ (cons tmp-680b775fb37a463-6d7
+ (cons tmp-680b775fb37a463-6d8
tmp-680b775fb37a463-6d9)))
+ 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
+ '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-68d
- tmp-680b775fb37a463-68c
- tmp-680b775fb37a463-68b)
- (cons tmp-680b775fb37a463-68b
- (cons tmp-680b775fb37a463-68c
tmp-680b775fb37a463-68d)))
+ (map (lambda (tmp-680b775fb37a463-68d
tmp-680b775fb37a463-68c tmp-680b775fb37a463-68b)
+ (cons tmp-680b775fb37a463-68b (cons
tmp-680b775fb37a463-68c tmp-680b775fb37a463-68d)))
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-6a3
- tmp-680b775fb37a463-6a2
- tmp-680b775fb37a463-6a1)
- (cons tmp-680b775fb37a463-6a1
- (cons tmp-680b775fb37a463-6a2
tmp-680b775fb37a463-6a3)))
- e2
- e1
- args)))
- tmp)
- (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
+ 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-6a3
tmp-680b775fb37a463-6a2 tmp-680b775fb37a463-6a1)
+ (cons tmp-680b775fb37a463-6a1
+ (cons tmp-680b775fb37a463-6a2
tmp-680b775fb37a463-6a3)))
+ 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)
- (syntax-sourcev 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))))))
+ '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)
+ (syntax-sourcev 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)))))))))
+ '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))))))
+ '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))))))
+ '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
+ '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))))))))
+ (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
+ '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)))))
+ (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
- (syntax-sourcev x)))
- ((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 (or (and (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))))))))))
+ '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 (syntax-sourcev x)))
+ ((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 (or (and (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)))))))
+ '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)
+ '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
ids))
- (lambda (p ids)
(values (vector 'vector p) ids))))
+ (lambda () (cvt x (+ n
1) ids))
+ (lambda (p ids)
+ (values (if (eq? p
'any) 'each-any (vector 'each 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
+ (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
- (list 'tmp)
+ (map syntax->datum ids)
#f
- (list y)
+ new-vars
'()
- (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
+ (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
- (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))))))
+ (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)))
- (letrec*
- ((unstrip
- (lambda (x)
- (letrec*
- ((annotate
- (lambda (result)
- (let ((props (source-properties x)))
- (if (pair? props) (datum->syntax #f result #:source
props) result)))))
- (cond ((pair? x) (annotate (cons (unstrip (car x)) (unstrip
(cdr x)))))
- ((vector? x)
- (let ((v (make-vector (vector-length x))))
- (annotate (list->vector (map unstrip (vector->list
x))))))
- ((syntax? x) x)
- (else (annotate x)))))))
- (expand-top-sequence
- (list (unstrip x))
- '()
- '((top))
- #f
- m
- esew
- (cons 'hygiene (module-name (current-module)))))))
+ (lambda* (x #:optional (m 'e) (esew '(eval)))
+ (letrec* ((unstrip
+ (lambda (x)
+ (letrec* ((annotate
+ (lambda (result)
+ (let ((props (source-properties x)))
+ (if (pair? props) (datum->syntax #f
result #:source props) result)))))
+ (cond
+ ((pair? x) (annotate (cons (unstrip (car x))
(unstrip (cdr x)))))
+ ((vector? x)
+ (let ((v (make-vector (vector-length x))))
+ (annotate (list->vector (map unstrip
(vector->list x))))))
+ ((syntax? x) x)
+ (else (annotate x)))))))
+ (expand-top-sequence
+ (list (unstrip x))
+ '()
+ '((top))
+ #f
+ m
+ esew
+ (cons 'hygiene (module-name (current-module)))))))
(set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax
- (lambda* (id datum #:key (source #f #:source))
- (letrec*
- ((props->sourcev
- (lambda (alist)
- (and (pair? alist)
- (vector
- (assq-ref alist 'filename)
- (assq-ref alist 'line)
- (assq-ref alist 'column))))))
- (make-syntax
- datum
- (if id (syntax-wrap id) '(()))
- (and id (syntax-module id))
- (cond ((not source) (props->sourcev (source-properties datum)))
- ((and (list? source) (and-map pair? source)) (props->sourcev
source))
- ((and (vector? source) (= 3 (vector-length source))) source)
- (else (syntax-sourcev source)))))))
+ (lambda* (id datum #:key (source #f #:source))
+ (letrec* ((props->sourcev
+ (lambda (alist)
+ (and (pair? alist)
+ (vector (assq-ref alist 'filename) (assq-ref
alist 'line) (assq-ref alist 'column))))))
+ (make-syntax
+ datum
+ (if id (syntax-wrap id) '(()))
+ (and id (syntax-module id))
+ (cond
+ ((not source) (props->sourcev (source-properties datum)))
+ ((and (list? source) (and-map pair? source)) (props->sourcev
source))
+ ((and (vector? source) (= 3 (vector-length source))) source)
+ (else (syntax-sourcev source)))))))
(set! syntax->datum (lambda (x) (strip 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))))
+ (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)))
+ (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)))
+ (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
- (sourcev->alist
- (or (source-annotation subform) (source-annotation form)))
- (strip form)
- (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 mod (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
- (or (syntax-module id) mod)
- resolve-syntax-parameters?))
- (lambda (type value mod)
- (let ((key type))
- (cond ((memv key '(lexical)) (values 'lexical value))
+ (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
+ (sourcev->alist (or (source-annotation subform)
(source-annotation form)))
+ (strip form)
+ (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 mod (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
+ (or (syntax-module id) mod)
+ 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)))))
+ (values 'primitive value)
+ (values 'global (cons value (cdr mod)))))
((memv key '(ellipsis))
- (values
- 'ellipsis
- (wrap-syntax value (anti-mark (syntax-wrap
value)) mod)))
+ (values 'ellipsis (wrap-syntax value (anti-mark
(syntax-wrap value)) mod)))
(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)))))
+ (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))
- (or (syntax-module e) mod)))
- (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)))))
+ (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)
- (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)) 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
- (or (syntax-module e) mod)))
- (else (match* e p w r mod))))))
+ (match-each (syntax-expression e) p (join-wraps w
(syntax-wrap e)) (or (syntax-module e) mod)))
+ (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)) 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 (or (syntax-module e) mod)))
+ (else (match* e p w r mod))))))
(set! $sc-dispatch
- (lambda (e p)
- (cond ((eq? p 'any) (list e))
+ (lambda (e p)
+ (cond
+ ((eq? p 'any) (list e))
((eq? p '_) '())
- ((syntax? e)
- (match*
- (syntax-expression e)
- p
- (syntax-wrap e)
- '()
- (syntax-module e)))
+ ((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))))))))))))
+ '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-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)))
+ (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))
+ 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))))))))))
+ '(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
+ '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))
+ (map (lambda (tmp-680b775fb37a463-11a3
tmp-680b775fb37a463-11a2 tmp-680b775fb37a463-11a1)
+ (list (cons tmp-680b775fb37a463-11a1
tmp-680b775fb37a463-11a2)
+ tmp-680b775fb37a463-11a3))
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-11a0
- tmp-680b775fb37a463-119f
- tmp-680b775fb37a463-119e)
- (list (cons tmp-680b775fb37a463-119e
tmp-680b775fb37a463-119f)
- tmp-680b775fb37a463-11a0))
- 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-11b9
- tmp-680b775fb37a463-11b8
- tmp-680b775fb37a463-11b7)
- (list (cons tmp-680b775fb37a463-11b7
tmp-680b775fb37a463-11b8)
- tmp-680b775fb37a463-11b9))
- 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
+ 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-11bc
+ tmp-680b775fb37a463-11bb
+ tmp-680b775fb37a463-11ba)
+ (list (cons tmp-680b775fb37a463-11ba
tmp-680b775fb37a463-11bb)
+ tmp-680b775fb37a463-11bc))
+ 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
- (list docstring)
- (map (lambda (tmp-680b775fb37a463-11d8
- tmp-680b775fb37a463-11d7
- tmp-680b775fb37a463-11d6)
- (list (cons
tmp-680b775fb37a463-11d6 tmp-680b775fb37a463-11d7)
- tmp-680b775fb37a463-11d8))
+ '()
+ (map (lambda (tmp-680b775fb37a463-11d5
+ tmp-680b775fb37a463-11d4
+ tmp-680b775fb37a463-11d3)
+ (list (cons
tmp-680b775fb37a463-11d3 tmp-680b775fb37a463-11d4)
+ tmp-680b775fb37a463-11d5))
template
pattern
keyword)))
- tmp-1)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp)))))))))))))))
+ 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-11f4
+
tmp-680b775fb37a463-11f3
+
tmp-680b775fb37a463-11f2)
+ (list (cons
tmp-680b775fb37a463-11f2 tmp-680b775fb37a463-11f3)
+
tmp-680b775fb37a463-11f4))
+ 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-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))))))))
+ '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)
+ '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-12a4)
+
(list "value"
+
tmp-680b775fb37a463-12a4))
+
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-12a9)
+
(list "value"
+
tmp-680b775fb37a463-12a9))
+
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
- (list (vector 'free-id (make-syntax
'unquote '((top)) '(hygiene guile)))
- 'any))))
+ (let ((tmp-1 ($sc-dispatch tmp '(any . 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
+ (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-12bf)
+ (list "value"
tmp-680b775fb37a463-12bf))
+ p)
+ (vquasi q lev))
+ (quasicons
+ (quasicons
+ (list "quote"
(make-syntax
'unquote '((top)) '(hygiene guile)))
- 'each-any))))
+ (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)
- (quasilist*
- (map (lambda
(tmp-680b775fb37a463)
- (list
"value" tmp-680b775fb37a463))
- 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)
+ (apply (lambda (p)
+ (if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-128d)
- (list
"value" tmp-680b775fb37a463-128d))
- p)
- (quasi q lev))
+ (map (lambda
(tmp-680b775fb37a463-12c4)
+ (list
"value" tmp-680b775fb37a463-12c4))
+ p)
+ (vquasi 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-12a3)
- (list "value"
tmp-680b775fb37a463-12a3))
- 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-12a8)
- (list "value"
tmp-680b775fb37a463-12a8))
- 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))))
+ (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 (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-12f1)
- (cons "vector"
t-680b775fb37a463-12f1))
- 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-12fd)
- (list "quote"
tmp-680b775fb37a463-12fd))
- 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-130c tmp))
- (list "list->vector"
t-680b775fb37a463-130c)))))))))))))))))
- (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-131b)
- (cons (make-syntax 'list
'((top)) '(hygiene guile))
-
t-680b775fb37a463-131b))
- 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-132f t-680b775fb37a463-132e)
- (list (make-syntax
'cons '((top)) '(hygiene guile))
-
t-680b775fb37a463-132f
-
t-680b775fb37a463-132e))
- tmp)
- (syntax-violation
+ (apply (lambda (p) (cons
"append" p)) 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))))
+ 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-130d)
+ (cons "vector"
t-680b775fb37a463-130d))
+ 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-133b)
- (cons (make-syntax
'append '((top)) '(hygiene guile))
-
t-680b775fb37a463-133b))
- 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 (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))
+ (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->vector") any))))
- (if tmp-1
- (apply (lambda (x)
- (let ((tmp (emit x)))
- (let ((t-680b775fb37a463
tmp))
- (list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463))))
+ #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-134b
+
t-680b775fb37a463-134a)
+
(list (make-syntax
+
'cons
+
'((top))
+
'(hygiene guile))
+
t-680b775fb37a463-134b
+
t-680b775fb37a463-134a))
+ tmp)
+
(syntax-violation
+ #f
+ "source
expression failed to match any pattern"
+ tmp-1)))))))
tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp
'(#(atom "value") any))))
+ (let ((tmp-1 ($sc-dispatch tmp
'(#(atom "append") . each-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)))))))))
+ (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-136f tmp))
+
(list (make-syntax
+
'list->vector
+
'((top))
+
'(hygiene guile))
+
t-680b775fb37a463-136f))))
+ 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 call-with-include-port
(let ((syntax-dirname
- (lambda (stx)
- (letrec*
- ((src (syntax-source stx))
- (filename (if src (assq-ref src 'filename) #f)))
- (if (string? filename) (dirname filename) #f)))))
+ (lambda (stx)
+ (letrec* ((src (syntax-source stx)) (filename (if src (assq-ref src
'filename) #f)))
+ (if (string? filename) (dirname filename) #f)))))
(lambda* (filename proc #:key (dirname (syntax-dirname filename)
#:dirname))
"Like @code{call-with-input-file}, except relative paths are\nsearched
relative to the @var{dirname} instead of the current working\ndirectory. Also,
@var{filename} can be a syntax object; in that case,\nand if @var{dirname} is
not specified, the @code{syntax-source} of\n@var{filename} is used to obtain a
base directory for relative file\nnames."
(let ((filename (syntax->datum filename)))
(let ((p (open-input-file
- (if (absolute-file-name? filename)
- filename
- (if dirname
- (in-vicinity dirname filename)
- (error "attempt to include relative file name but could
not determine base dir"))))))
+ (if (absolute-file-name? filename)
+ filename
+ (if dirname
+ (in-vicinity dirname filename)
+ (error "attempt to include relative file name but
could not determine base dir"))))))
(let ((enc (file-encoding p)))
(set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
- (call-with-values
- (lambda () (proc p))
- (lambda results (close-port p) (apply values results)))))))))
+ (call-with-values (lambda () (proc p)) (lambda results (close-port
p) (apply values results)))))))))
(define include
(let ((make-syntax make-syntax))
(make-syntax-transformer
- 'include
- 'macro
- (lambda (stx)
- (let ((tmp-1 stx))
- (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
- (if tmp
- (apply (lambda (filename)
- (call-with-include-port
+ 'include
+ 'macro
+ (lambda (stx)
+ (let ((tmp-1 stx))
+ (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
+ (if tmp
+ (apply (lambda (filename)
+ (call-with-include-port
filename
(lambda (p)
(cons (make-syntax 'begin '((top)) '(hygiene guile))
(let lp ()
(let ((x (read-syntax p)))
(if (eof-object? x) '() (cons
(datum->syntax filename x) (lp)))))))))
- 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
+ '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))))))))
+ (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))))
+ '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))))
+ '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))))
+ (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
+ '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)
+ 'identifier-syntax
+ (list '(top)
+ (vector
+ 'ribcage
+ '#(identifier-syntax)
+ '#((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
+ (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)
+ (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))))))))))
+ (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))))))))))
+ '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))))))))))