mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

psyntax: Separate core expanders from their installation

Browse source 
* module/ice-9/psyntax.scm (expand-let, expand-letrec, ...): Name these
expanders, then install them.  Allows for better code evolution and
decreases the indent.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-18 16:53:41 +01:00
parent 6c4f9a58c9
commit cdf8473b19
2 changed files with 1424 additions and 1394 deletions
Download patch file Download diff file Expand all files Collapse all files

295
module/ice-9/psyntax-pp.scm
View file

@ -1151,11 +1151,11 @@
(source-wrap e w (wrap-subst w) mod) (source-wrap e w (wrap-subst w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-10a3 transformer-environment) (let* ((t-680b775fb37a463-c51 transformer-environment)
(t-680b775fb37a463-10a4 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-c52 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-10a3 t-680b775fb37a463-c51
t-680b775fb37a463-10a4 t-680b775fb37a463-c52
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -1686,11 +1686,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-132c (map (lambda (tmp-680b775fb37a463-eda
tmp-680b775fb37a463-132b tmp-680b775fb37a463-ed9
tmp-680b775fb37a463-132a) tmp-680b775fb37a463-ed8)
(cons tmp-680b775fb37a463-132a (cons tmp-680b775fb37a463-ed8
(cons tmp-680b775fb37a463-132b tmp-680b775fb37a463-132c))) (cons tmp-680b775fb37a463-ed9 tmp-680b775fb37a463-eda)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1721,12 +1721,8 @@
((id? vars) (cons (wrap vars w #f) ls)) ((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls) ((null? vars) ls)
((syntax? vars) (lvl (syntax-expression vars) ls (join-wraps w (syntax-wrap vars)))) ((syntax? vars) (lvl (syntax-expression vars) ls (join-wraps w (syntax-wrap vars))))
(else (cons vars ls))))))) (else (cons vars ls))))))
(global-extend 'local-syntax 'letrec-syntax #t) (expand-syntax-parameterize
(global-extend 'local-syntax 'let-syntax #f)
(global-extend
'core
'syntax-parameterize
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) (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)) (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
@ -1753,28 +1749,25 @@
(bindings (bindings
(let ((trans-r (macros-only-env r))) (let ((trans-r (macros-only-env r)))
(map (lambda (x) (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)))) val))))
(expand-body (cons e1 e2) (source-wrap e w s mod) (extend-env names bindings r) w mod))) (expand-body (cons e1 e2) (source-wrap e w s mod) (extend-env names bindings r) w mod)))
tmp) tmp)
(syntax-violation 'syntax-parameterize "bad syntax" (source-wrap e w s mod)))))) (syntax-violation 'syntax-parameterize "bad syntax" (source-wrap e w s mod))))))
(global-extend (expand-quote
'core
'quote
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
(if tmp (if tmp
(apply (lambda (e) (build-data s (strip e))) tmp) (apply (lambda (e) (build-data s (strip e))) tmp)
(syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
(global-extend (expand-quote-syntax
'core
'quote-syntax
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp-1 (source-wrap e w s mod)) (tmp ($sc-dispatch tmp-1 '(_ any)))) (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)))))) (if tmp
(global-extend (apply (lambda (e) (build-data s e)) tmp)
'core (let ((e tmp-1)) (syntax-violation 'quote "bad syntax" e))))))
'syntax (expand-syntax
(letrec* ((gen-syntax (letrec* ((gen-syntax
(lambda (src e r maps ellipsis? mod) (lambda (src e r maps ellipsis? mod)
(if (id? e) (if (id? e)
@ -1798,13 +1791,15 @@
(let f ((y y) (let f ((y y)
(k (lambda (maps) (k (lambda (maps)
(call-with-values (call-with-values
(lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod)) (lambda ()
(gen-syntax src x r (cons '() maps) ellipsis? mod))
(lambda (x maps) (lambda (x maps)
(if (null? (car maps)) (if (null? (car maps))
(syntax-violation 'syntax "extra ellipsis" src) (syntax-violation 'syntax "extra ellipsis" src)
(values (gen-map x (car maps)) (cdr maps)))))))) (values (gen-map x (car maps)) (cdr maps))))))))
(let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
(if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) (if (and tmp
(apply (lambda (dots y) (ellipsis? dots r mod)) tmp))
(apply (lambda (dots y) (apply (lambda (dots y)
(f y (f y
(lambda (maps) (lambda (maps)
@ -1812,8 +1807,13 @@
(lambda () (k (cons '() maps))) (lambda () (k (cons '() maps)))
(lambda (x maps) (lambda (x maps)
(if (null? (car maps)) (if (null? (car maps))
(syntax-violation 'syntax "extra ellipsis" src) (syntax-violation
(values (gen-mappend x (car maps)) (cdr maps)))))))) 'syntax
"extra ellipsis"
src)
(values
(gen-mappend x (car maps))
(cdr maps))))))))
tmp) tmp)
(call-with-values (call-with-values
(lambda () (gen-syntax src y r maps ellipsis? mod)) (lambda () (gen-syntax src y r maps ellipsis? mod))
@ -1836,11 +1836,13 @@
(if tmp-1 (if tmp-1
(apply (lambda (e1 e2) (apply (lambda (e1 e2)
(call-with-values (call-with-values
(lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) (lambda ()
(gen-syntax src (cons e1 e2) r maps ellipsis? mod))
(lambda (e maps) (values (gen-vector e) maps)))) (lambda (e maps) (values (gen-vector e) maps))))
tmp-1) tmp-1)
(let ((tmp-1 (list tmp))) (let ((tmp-1 (list tmp)))
(if (and tmp-1 (apply (lambda (x) (eq? (syntax->datum x) #nil)) tmp-1)) (if (and tmp-1
(apply (lambda (x) (eq? (syntax->datum x) #nil)) tmp-1))
(apply (lambda (x) (values ''#nil maps)) tmp-1) (apply (lambda (x) (values ''#nil maps)) tmp-1)
(let ((tmp ($sc-dispatch tmp '()))) (let ((tmp ($sc-dispatch tmp '())))
(if tmp (if tmp
@ -1858,7 +1860,9 @@
(if b (if b
(values (cdr b) maps) (values (cdr b) maps)
(let ((inner-var (gen-var 'tmp))) (let ((inner-var (gen-var 'tmp)))
(values inner-var (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) (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-mappend (lambda (e map-env) (list 'apply '(primitive append) (gen-map e map-env))))
(gen-map (gen-map
(lambda (e map-env) (lambda (e map-env)
@ -1868,7 +1872,8 @@
((and-map (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (cdr e)) ((and-map (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (cdr e))
(cons 'map (cons 'map
(cons (list 'primitive (car e)) (cons (list 'primitive (car e))
(map (let ((r (map cons formals actuals))) (lambda (x) (cdr (assq (cadr x) r)))) (map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))) (cdr e)))))
(else (cons 'map (cons (list 'lambda formals e) actuals))))))) (else (cons 'map (cons (list 'lambda formals e) actuals)))))))
(gen-cons (gen-cons
@ -1904,12 +1909,12 @@
(let* ((e (source-wrap e w s mod)) (tmp e) (tmp ($sc-dispatch tmp '(_ any)))) (let* ((e (source-wrap e w s mod)) (tmp e) (tmp ($sc-dispatch tmp '(_ any))))
(if tmp (if tmp
(apply (lambda (x) (apply (lambda (x)
(call-with-values (lambda () (gen-syntax e x r '() ellipsis? mod)) (lambda (e maps) (regen e)))) (call-with-values
(lambda () (gen-syntax e x r '() ellipsis? mod))
(lambda (e maps) (regen e))))
tmp) tmp)
(syntax-violation 'syntax "bad `syntax' form" e)))))) (syntax-violation 'syntax "bad `syntax' form" e))))))
(global-extend (expand-lambda
'core
'lambda
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
(if tmp (if tmp
@ -1919,10 +1924,13 @@
(lambda (req opt rest kw) (lambda (req opt rest kw)
(let lp ((body (cons e1 e2)) (meta '())) (let lp ((body (cons e1 e2)) (meta '()))
(let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any)))) (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)) (if (and tmp
(apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) tmp))
(apply (lambda (docstring e1 e2) (apply (lambda (docstring e1 e2)
(lp (cons e1 e2) (lp (cons e1 e2)
(append meta (list (cons 'documentation (syntax->datum docstring)))))) (append
meta
(list (cons 'documentation (syntax->datum docstring))))))
tmp) tmp)
(let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any)))) (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
(if tmp (if tmp
@ -1932,21 +1940,18 @@
(expand-simple-lambda e r w s mod req rest meta body))))))))) (expand-simple-lambda e r w s mod req rest meta body)))))))))
tmp) tmp)
(syntax-violation 'lambda "bad lambda" e))))) (syntax-violation 'lambda "bad lambda" e)))))
(global-extend (expand-lambda*
'core
'lambda*
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
(if tmp (if tmp
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(call-with-values (call-with-values
(lambda () (expand-lambda-case e r w s mod lambda*-formals (list (cons args (cons e1 e2))))) (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)))) (lambda (meta lcase) (build-case-lambda s meta lcase))))
tmp) tmp)
(syntax-violation 'lambda "bad lambda*" e))))) (syntax-violation 'lambda "bad lambda*" e)))))
(global-extend (expand-case-lambda
'core
'case-lambda
(lambda (e r w s mod) (lambda (e r w s mod)
(letrec* ((build-it (letrec* ((build-it
(lambda (meta clauses) (lambda (meta clauses)
@ -1958,8 +1963,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-113f
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) tmp-680b775fb37a463-113e
tmp-680b775fb37a463-113d)
(cons tmp-680b775fb37a463-113d
(cons tmp-680b775fb37a463-113e tmp-680b775fb37a463-113f)))
e2 e2
e1 e1
args))) args)))
@ -1969,17 +1977,15 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6ae tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ac) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-6ac (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ae))) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2 e2
e1 e1
args))) args)))
tmp) tmp)
(syntax-violation 'case-lambda "bad case-lambda" e)))))))) (syntax-violation 'case-lambda "bad case-lambda" e))))))))
(global-extend (expand-case-lambda*
'core
'case-lambda*
(lambda (e r w s mod) (lambda (e r w s mod)
(letrec* ((build-it (letrec* ((build-it
(lambda (meta clauses) (lambda (meta clauses)
@ -2002,16 +2008,17 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-118b
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) tmp-680b775fb37a463-118a
tmp-680b775fb37a463)
(cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-118a tmp-680b775fb37a463-118b)))
e2 e2
e1 e1
args))) args)))
tmp) tmp)
(syntax-violation 'case-lambda "bad case-lambda*" e)))))))) (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
(global-extend (expand-with-ellipsis
'core
'with-ellipsis
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
(if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp))
@ -2030,9 +2037,7 @@
(expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod)))))
tmp) tmp)
(syntax-violation 'with-ellipsis "bad syntax" (source-wrap e w s mod)))))) (syntax-violation 'with-ellipsis "bad syntax" (source-wrap e w s mod))))))
(global-extend (expand-let
'core
'let
(letrec* ((expand-let (letrec* ((expand-let
(lambda (e r w s mod constructor ids vals exps) (lambda (e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids)) (if (not (valid-bound-ids? ids))
@ -2055,9 +2060,7 @@
(expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2))) (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2)))
tmp) tmp)
(syntax-violation 'let "bad let" (source-wrap e w s mod))))))))) (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
(global-extend (expand-letrec
'core
'letrec
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
(if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
@ -2076,9 +2079,7 @@
(expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
tmp) tmp)
(syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
(global-extend (expand-letrec*
'core
'letrec*
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
(if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
@ -2097,9 +2098,7 @@
(expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
tmp) tmp)
(syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
(global-extend (expand-set!
'core
'set!
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
(if (and tmp (apply (lambda (id val) (id? id)) tmp)) (if (and tmp (apply (lambda (id val) (id? id)) tmp))
@ -2111,7 +2110,8 @@
(cond (cond
((memv key '(lexical)) ((memv key '(lexical))
(build-lexical-assignment s (syntax->datum id) value (expand val r w mod))) (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 '(global))
(build-global-assignment s value (expand val r w mod) id-mod))
((memv key '(macro)) ((memv key '(macro))
(if (procedure-property value 'variable-transformer) (if (procedure-property value 'variable-transformer)
(expand (expand-macro value e r w s #f mod) r empty-wrap mod) (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
@ -2147,13 +2147,15 @@
tmp-1)))))) tmp-1))))))
(build-call (build-call
s s
(expand (list (make-syntax 'setter '((top)) '(hygiene guile)) head) r w mod) (expand
(list (make-syntax 'setter '((top)) '(hygiene guile)) head)
r
w
mod)
(map (lambda (e) (expand e r w mod)) (append tail (list val))))))))) (map (lambda (e) (expand e r w mod)) (append tail (list val)))))))))
tmp) tmp)
(syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
(global-extend (expand-public-ref
'module-ref
'@
(lambda (e r w mod) (lambda (e r w mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) (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)) (if (and tmp (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
@ -2166,16 +2168,18 @@
(syntax->datum (cons (make-syntax 'public '((top)) '(hygiene guile)) mod)))) (syntax->datum (cons (make-syntax 'public '((top)) '(hygiene guile)) mod))))
tmp) tmp)
(syntax-violation #f "source expression failed to match any pattern" tmp-1))))) (syntax-violation #f "source expression failed to match any pattern" tmp-1)))))
(global-extend (expand-private-ref
'module-ref
'@@
(lambda (e r w mod) (lambda (e r w mod)
(letrec* ((remodulate (letrec* ((remodulate
(lambda (x mod) (lambda (x mod)
(cond (cond
((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod))) ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod)))
((syntax? x) ((syntax? x)
(make-syntax (remodulate (syntax-expression x) mod) (syntax-wrap x) mod (syntax-sourcev x))) (make-syntax
(remodulate (syntax-expression x) mod)
(syntax-wrap x)
mod
(syntax-sourcev x)))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (make-vector n))) (let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0)) (let loop ((i 0))
@ -2189,7 +2193,8 @@
(list '_ (vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile))) 'any)))) (list '_ (vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile))) 'any))))
(if (and tmp-1 (if (and tmp-1
(apply (lambda (id) (apply (lambda (id)
(and (id? id) (equal? (cdr (or (and (syntax? id) (syntax-module id)) mod)) '(guile)))) (and (id? id)
(equal? (cdr (or (and (syntax? id) (syntax-module id)) mod)) '(guile))))
tmp-1)) tmp-1))
(apply (lambda (id) (values (syntax->datum id) r top-wrap #f '(primitive))) tmp-1) (apply (lambda (id) (values (syntax->datum id) r top-wrap #f '(primitive))) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
@ -2215,9 +2220,7 @@
(values (remodulate exp mod) r w (source-annotation exp) mod))) (values (remodulate exp mod) r w (source-annotation exp) mod)))
tmp-1) tmp-1)
(syntax-violation #f "source expression failed to match any pattern" tmp)))))))))) (syntax-violation #f "source expression failed to match any pattern" tmp))))))))))
(global-extend (expand-if
'core
'if
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
(if tmp-1 (if tmp-1
@ -2227,17 +2230,14 @@
(let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
(if tmp-1 (if tmp-1
(apply (lambda (test then else) (apply (lambda (test then else)
(build-conditional s (expand test r w mod) (expand then r w mod) (expand else r w mod))) (build-conditional
s
(expand test r w mod)
(expand then r w mod)
(expand else r w mod)))
tmp-1) tmp-1)
(syntax-violation #f "source expression failed to match any pattern" tmp))))))) (syntax-violation #f "source expression failed to match any pattern" tmp)))))))
(global-extend 'begin 'begin '()) (expand-syntax-case
(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 (letrec* ((convert-pattern
(lambda (pattern keys ellipsis?) (lambda (pattern keys ellipsis?)
(letrec* ((cvt* (lambda (p* n ids) (letrec* ((cvt* (lambda (p* n ids)
@ -2260,7 +2260,8 @@
(if (id? p) (if (id? p)
(cond (cond
((bound-id-member? p keys) (values (vector 'free-id p) ids)) ((bound-id-member? p keys) (values (vector 'free-id p) ids))
((free-id=? p (make-syntax '_ '((top)) '(hygiene guile))) (values '_ ids)) ((free-id=? p (make-syntax '_ '((top)) '(hygiene guile)))
(values '_ ids))
(else (values 'any (cons (cons p n) ids)))) (else (values 'any (cons (cons p n) ids))))
(let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
(if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1))
@ -2268,10 +2269,13 @@
(call-with-values (call-with-values
(lambda () (cvt x (#{1+}# n) ids)) (lambda () (cvt x (#{1+}# n) ids))
(lambda (p ids) (lambda (p ids)
(values (if (eq? p 'any) 'each-any (vector 'each p)) ids)))) (values
(if (eq? p 'any) 'each-any (vector 'each p))
ids))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
(if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1)) (if (and tmp-1
(apply (lambda (x dots ys) (ellipsis? dots)) tmp-1))
(apply (lambda (x dots ys) (apply (lambda (x dots ys)
(call-with-values (call-with-values
(lambda () (cvt* ys n ids)) (lambda () (cvt* ys n ids))
@ -2281,7 +2285,8 @@
(lambda (x ids) (lambda (x ids)
(call-with-values (call-with-values
(lambda () (v-reverse ys)) (lambda () (v-reverse ys))
(lambda (ys e) (values (vector 'each+ x ys e) ids)))))))) (lambda (ys e)
(values (vector 'each+ x ys e) ids))))))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any . any)))) (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
(if tmp-1 (if tmp-1
@ -2296,7 +2301,9 @@
(let ((tmp-1 ($sc-dispatch tmp '()))) (let ((tmp-1 ($sc-dispatch tmp '())))
(if tmp-1 (if tmp-1
(apply (lambda () (values '() ids)) tmp-1) (apply (lambda () (values '() ids)) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) (let ((tmp-1 ($sc-dispatch
tmp
'#(vector each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(call-with-values (call-with-values
@ -2324,7 +2331,9 @@
exp exp
(extend-env (extend-env
labels labels
(map (lambda (var level) (cons 'syntax (cons var level))) new-vars (map cdr pvars)) (map (lambda (var level) (cons 'syntax (cons var level)))
new-vars
(map cdr pvars))
r) r)
(make-binding-wrap ids labels empty-wrap) (make-binding-wrap ids labels empty-wrap)
mod)) mod))
@ -2363,7 +2372,10 @@
(gen-syntax-case x keys clauses r mod)))) (gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any) (list (if (eq? p 'any)
(build-primcall no-source 'list (list x)) (build-primcall no-source 'list (list x))
(build-primcall no-source '$sc-dispatch (list x (build-data no-source p))))))))))))) (build-primcall
no-source
'$sc-dispatch
(list x (build-data no-source p)))))))))))))
(gen-syntax-case (gen-syntax-case
(lambda (x keys clauses r mod) (lambda (x keys clauses r mod)
(if (null? clauses) (if (null? clauses)
@ -2423,7 +2435,31 @@
(list (expand val r empty-wrap mod)))) (list (expand val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))) (syntax-violation 'syntax-case "invalid literals list" e)))
tmp) tmp)
(syntax-violation #f "source expression failed to match any pattern" tmp-1)))))) (syntax-violation #f "source expression failed to match any pattern" tmp-1)))))))
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
(global-extend 'core 'syntax-parameterize expand-syntax-parameterize)
(global-extend 'core 'quote expand-quote)
(global-extend 'core 'quote-syntax expand-quote-syntax)
(global-extend 'core 'syntax expand-syntax)
(global-extend 'core 'lambda expand-lambda)
(global-extend 'core 'lambda* expand-lambda*)
(global-extend 'core 'case-lambda expand-case-lambda)
(global-extend 'core 'case-lambda* expand-case-lambda*)
(global-extend 'core 'with-ellipsis expand-with-ellipsis)
(global-extend 'core 'let expand-let)
(global-extend 'core 'letrec expand-letrec)
(global-extend 'core 'letrec* expand-letrec*)
(global-extend 'core 'set! expand-set!)
(global-extend 'module-ref '@ expand-public-ref)
(global-extend 'module-ref '@@ expand-private-ref)
(global-extend 'core 'if expand-if)
(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 expand-syntax-case)
(set! macroexpand (set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval))) (lambda* (x #:optional (m 'e) (esew '(eval)))
(letrec* ((unstrip (letrec* ((unstrip
@ -2802,9 +2838,8 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-145f tmp-680b775fb37a463-145e) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-145e tmp-680b775fb37a463-145f) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
tmp-680b775fb37a463))
template template
pattern pattern
keyword))) keyword)))
@ -2816,9 +2851,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-149b
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-149a
tmp-680b775fb37a463-2)) tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-149a)
tmp-680b775fb37a463-149b))
template template
pattern pattern
keyword))) keyword)))
@ -2834,11 +2871,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 (map (lambda (tmp-680b775fb37a463-14ba
tmp-680b775fb37a463-1 tmp-680b775fb37a463-14b9
tmp-680b775fb37a463) tmp-680b775fb37a463-14b8)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463-14b8 tmp-680b775fb37a463-14b9)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-14ba))
template template
pattern pattern
keyword))) keyword)))
@ -2993,9 +3030,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-154a) (map (lambda (tmp-680b775fb37a463-156c)
(list "value" (list "value"
tmp-680b775fb37a463-154a)) tmp-680b775fb37a463-156c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3135,8 +3172,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15ae) (apply (lambda (t-680b775fb37a463-15d0)
(cons "vector" t-680b775fb37a463-15ae)) (cons "vector" t-680b775fb37a463-15d0))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3146,8 +3183,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-15ba) (k (map (lambda (tmp-680b775fb37a463-15dc)
(list "quote" tmp-680b775fb37a463-15ba)) (list "quote" tmp-680b775fb37a463-15dc))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3158,8 +3195,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-15c9 tmp)) (let ((t-680b775fb37a463-15eb tmp))
(list "list->vector" t-680b775fb37a463-15c9))))))))))))))))) (list "list->vector" t-680b775fb37a463-15eb)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3171,9 +3208,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15d8) (apply (lambda (t-680b775fb37a463-15fa)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-15d8)) t-680b775fb37a463-15fa))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3189,14 +3226,14 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15ec (apply (lambda (t-680b775fb37a463-160e
t-680b775fb37a463-15eb) t-680b775fb37a463-160d)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-15ec t-680b775fb37a463-160e
t-680b775fb37a463-15eb)) t-680b775fb37a463-160d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3209,12 +3246,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15f8) (apply (lambda (t-680b775fb37a463-161a)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-15f8)) t-680b775fb37a463-161a))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

119
module/ice-9/psyntax.scm
View file

@ -1934,12 +1934,7 @@
;; core transformers ;; core transformers
(global-extend 'local-syntax 'letrec-syntax #t) (define (expand-syntax-parameterize e r w s mod)
(global-extend 'local-syntax 'let-syntax #f)
(global-extend
'core 'syntax-parameterize
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((var val) ...) e1 e2 ...) ((_ ((var val) ...) e1 e2 ...)
(valid-bound-ids? #'(var ...)) (valid-bound-ids? #'(var ...))
@ -1975,23 +1970,20 @@
w w
mod))) mod)))
(_ (syntax-violation 'syntax-parameterize "bad syntax" (_ (syntax-violation 'syntax-parameterize "bad syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod)))))
(global-extend 'core 'quote (define (expand-quote e r w s mod)
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ e) (build-data s (strip #'e))) ((_ e) (build-data s (strip #'e)))
(_ (syntax-violation 'quote "bad syntax" (_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod)))))
(global-extend 'core 'quote-syntax (define (expand-quote-syntax e r w s mod)
(lambda (e r w s mod)
(syntax-case (source-wrap e w s mod) () (syntax-case (source-wrap e w s mod) ()
((_ e) (build-data s #'e)) ((_ e) (build-data s #'e))
(e (syntax-violation 'quote "bad syntax" #'e))))) (e (syntax-violation 'quote "bad syntax" #'e))))
(global-extend (define expand-syntax
'core 'syntax
(let () (let ()
(define (gen-syntax src e r maps ellipsis? mod) (define (gen-syntax src e r maps ellipsis? mod)
(if (id? e) (if (id? e)
@ -2145,8 +2137,7 @@
(lambda (e maps) (regen e)))) (lambda (e maps) (regen e))))
(_ (syntax-violation 'syntax "bad `syntax' form" e))))))) (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda (define (expand-lambda e r w s mod)
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ args e1 e2 ...) ((_ args e1 e2 ...)
(call-with-values (lambda () (lambda-formals #'args)) (call-with-values (lambda () (lambda-formals #'args))
@ -2162,10 +2153,9 @@
(lp #'(e1 e2 ...) (lp #'(e1 e2 ...)
(append meta (syntax->datum #'((k . v) ...))))) (append meta (syntax->datum #'((k . v) ...)))))
(_ (expand-simple-lambda e r w s mod req rest meta body))))))) (_ (expand-simple-lambda e r w s mod req rest meta body)))))))
(_ (syntax-violation 'lambda "bad lambda" e))))) (_ (syntax-violation 'lambda "bad lambda" e))))
(global-extend 'core 'lambda* (define (expand-lambda* e r w s mod)
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ args e1 e2 ...) ((_ args e1 e2 ...)
(call-with-values (call-with-values
@ -2174,10 +2164,9 @@
lambda*-formals #'((args e1 e2 ...)))) lambda*-formals #'((args e1 e2 ...))))
(lambda (meta lcase) (lambda (meta lcase)
(build-case-lambda s meta lcase)))) (build-case-lambda s meta lcase))))
(_ (syntax-violation 'lambda "bad lambda*" e))))) (_ (syntax-violation 'lambda "bad lambda*" e))))
(global-extend 'core 'case-lambda (define (expand-case-lambda e r w s mod)
(lambda (e r w s mod)
(define (build-it meta clauses) (define (build-it meta clauses)
(call-with-values (call-with-values
(lambda () (lambda ()
@ -2194,10 +2183,9 @@
(build-it `((documentation (build-it `((documentation
. ,(syntax->datum #'docstring))) . ,(syntax->datum #'docstring)))
#'((args e1 e2 ...) ...))) #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda" e))))) (_ (syntax-violation 'case-lambda "bad case-lambda" e))))
(global-extend 'core 'case-lambda* (define (expand-case-lambda* e r w s mod)
(lambda (e r w s mod)
(define (build-it meta clauses) (define (build-it meta clauses)
(call-with-values (call-with-values
(lambda () (lambda ()
@ -2214,10 +2202,9 @@
(build-it `((documentation (build-it `((documentation
. ,(syntax->datum #'docstring))) . ,(syntax->datum #'docstring)))
#'((args e1 e2 ...) ...))) #'((args e1 e2 ...) ...)))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))
(global-extend 'core 'with-ellipsis (define (expand-with-ellipsis e r w s mod)
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ dots e1 e2 ...) ((_ dots e1 e2 ...)
(id? #'dots) (id? #'dots)
@ -2234,9 +2221,9 @@
(nr (extend-env labels bindings r))) (nr (extend-env labels bindings r)))
(expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod))))) (expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod)))))
(_ (syntax-violation 'with-ellipsis "bad syntax" (_ (syntax-violation 'with-ellipsis "bad syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod)))))
(global-extend 'core 'let (define expand-let
(let () (let ()
(define (expand-let e r w s mod constructor ids vals exps) (define (expand-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids)) (if (not (valid-bound-ids? ids))
@ -2269,9 +2256,7 @@
#'(e1 e2 ...))) #'(e1 e2 ...)))
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
(define (expand-letrec e r w s mod)
(global-extend 'core 'letrec
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((id val) ...) e1 e2 ...) ((_ ((id val) ...) e1 e2 ...)
(and-map id? #'(id ...)) (and-map id? #'(id ...))
@ -2288,11 +2273,9 @@
(map (lambda (x) (expand x r w mod)) #'(val ...)) (map (lambda (x) (expand x r w mod)) #'(val ...))
(expand-body #'(e1 e2 ...) (expand-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod))))))) (source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))
(define (expand-letrec* e r w s mod)
(global-extend 'core 'letrec*
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((id val) ...) e1 e2 ...) ((_ ((id val) ...) e1 e2 ...)
(and-map id? #'(id ...)) (and-map id? #'(id ...))
@ -2309,12 +2292,9 @@
(map (lambda (x) (expand x r w mod)) #'(val ...)) (map (lambda (x) (expand x r w mod)) #'(val ...))
(expand-body #'(e1 e2 ...) (expand-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod))))))) (source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))
(define (expand-set! e r w s mod)
(global-extend
'core 'set!
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ id val) ((_ id val)
(id? #'id) (id? #'id)
@ -2358,10 +2338,9 @@
(expand #'(setter head) r w mod) (expand #'(setter head) r w mod)
(map (lambda (e) (expand e r w mod)) (map (lambda (e) (expand e r w mod))
#'(tail ... val)))))))) #'(tail ... val))))))))
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))
(global-extend 'module-ref '@ (define (expand-public-ref e r w mod)
(lambda (e r w mod)
(syntax-case e () (syntax-case e ()
((_ (mod ...) id) ((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id)) (and (and-map id? #'(mod ...)) (id? #'id))
@ -2369,10 +2348,9 @@
;; so that the identifier will not be captured by lexicals. ;; so that the identifier will not be captured by lexicals.
(values (syntax->datum #'id) r top-wrap #f (values (syntax->datum #'id) r top-wrap #f
(syntax->datum (syntax->datum
#'(public mod ...))))))) #'(public mod ...))))))
(global-extend 'module-ref '@@ (define (expand-private-ref e r w mod)
(lambda (e r w mod)
(define (remodulate x mod) (define (remodulate x mod)
(cond ((pair? x) (cond ((pair? x)
(cons (remodulate (car x) mod) (cons (remodulate (car x) mod)
@ -2416,10 +2394,9 @@
(let ((mod (syntax->datum #'(private mod ...)))) (let ((mod (syntax->datum #'(private mod ...))))
(values (remodulate #'exp mod) (values (remodulate #'exp mod)
r w (source-annotation #'exp) r w (source-annotation #'exp)
mod)))))) mod)))))
(global-extend 'core 'if (define (expand-if e r w s mod)
(lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ test then) ((_ test then)
(build-conditional (build-conditional
@ -2432,18 +2409,9 @@
s s
(expand #'test r w mod) (expand #'test r w mod)
(expand #'then r w mod) (expand #'then r w mod)
(expand #'else r w mod)))))) (expand #'else r w mod)))))
(global-extend 'begin 'begin '()) (define expand-syntax-case
(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
(let () (let ()
(define (convert-pattern pattern keys ellipsis?) (define (convert-pattern pattern keys ellipsis?)
;; accepts pattern & keys ;; accepts pattern & keys
@ -2615,6 +2583,31 @@
(list (expand #'val r empty-wrap mod)))) (list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e)))))))) (syntax-violation 'syntax-case "invalid literals list" e))))))))
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
(global-extend 'core 'syntax-parameterize expand-syntax-parameterize)
(global-extend 'core 'quote expand-quote)
(global-extend 'core 'quote-syntax expand-quote-syntax)
(global-extend 'core 'syntax expand-syntax)
(global-extend 'core 'lambda expand-lambda)
(global-extend 'core 'lambda* expand-lambda*)
(global-extend 'core 'case-lambda expand-case-lambda)
(global-extend 'core 'case-lambda* expand-case-lambda*)
(global-extend 'core 'with-ellipsis expand-with-ellipsis)
(global-extend 'core 'let expand-let)
(global-extend 'core 'letrec expand-letrec)
(global-extend 'core 'letrec* expand-letrec*)
(global-extend 'core 'set! expand-set!)
(global-extend 'module-ref '@ expand-public-ref)
(global-extend 'module-ref '@@ expand-private-ref)
(global-extend 'core 'if expand-if)
(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 expand-syntax-case)
;; The portable macroexpand seeds expand-top's mode m with 'e (for ;; The portable macroexpand seeds expand-top's mode m with 'e (for
;; evaluating) and esew (which stands for "eval syntax expanders ;; evaluating) and esew (which stands for "eval syntax expanders
;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e