mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-29 22:40:34 +02:00
psyntax: Separate core expanders from their installation
* 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
parent
6c4f9a58c9
commit
cdf8473b19
2 changed files with 1424 additions and 1394 deletions
|
|
@ -1151,11 +1151,11 @@
|
|||
(source-wrap e w (wrap-subst w) mod)
|
||||
x))
|
||||
(else (decorate-source x))))))
|
||||
(let* ((t-680b775fb37a463-10a3 transformer-environment)
|
||||
(t-680b775fb37a463-10a4 (lambda (k) (k e r w s rib mod))))
|
||||
(let* ((t-680b775fb37a463-c51 transformer-environment)
|
||||
(t-680b775fb37a463-c52 (lambda (k) (k e r w s rib mod))))
|
||||
(with-fluid*
|
||||
t-680b775fb37a463-10a3
|
||||
t-680b775fb37a463-10a4
|
||||
t-680b775fb37a463-c51
|
||||
t-680b775fb37a463-c52
|
||||
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
|
||||
(expand-body
|
||||
(lambda (body outer-form r w mod)
|
||||
|
|
@ -1686,11 +1686,11 @@
|
|||
s
|
||||
mod
|
||||
get-formals
|
||||
(map (lambda (tmp-680b775fb37a463-132c
|
||||
tmp-680b775fb37a463-132b
|
||||
tmp-680b775fb37a463-132a)
|
||||
(cons tmp-680b775fb37a463-132a
|
||||
(cons tmp-680b775fb37a463-132b tmp-680b775fb37a463-132c)))
|
||||
(map (lambda (tmp-680b775fb37a463-eda
|
||||
tmp-680b775fb37a463-ed9
|
||||
tmp-680b775fb37a463-ed8)
|
||||
(cons tmp-680b775fb37a463-ed8
|
||||
(cons tmp-680b775fb37a463-ed9 tmp-680b775fb37a463-eda)))
|
||||
e2*
|
||||
e1*
|
||||
args*)))
|
||||
|
|
@ -1721,12 +1721,8 @@
|
|||
((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
|
||||
(else (cons vars ls))))))
|
||||
(expand-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))
|
||||
|
|
@ -1753,28 +1749,25 @@
|
|||
(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))))))
|
||||
(global-extend
|
||||
'core
|
||||
'quote
|
||||
(expand-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
|
||||
(expand-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
|
||||
(if tmp
|
||||
(apply (lambda (e) (build-data s e)) tmp)
|
||||
(let ((e tmp-1)) (syntax-violation 'quote "bad syntax" e))))))
|
||||
(expand-syntax
|
||||
(letrec* ((gen-syntax
|
||||
(lambda (src e r maps ellipsis? mod)
|
||||
(if (id? e)
|
||||
|
|
@ -1798,13 +1791,15 @@
|
|||
(let f ((y y)
|
||||
(k (lambda (maps)
|
||||
(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)
|
||||
(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))
|
||||
(if (and tmp
|
||||
(apply (lambda (dots y) (ellipsis? dots r mod)) tmp))
|
||||
(apply (lambda (dots y)
|
||||
(f y
|
||||
(lambda (maps)
|
||||
|
|
@ -1812,8 +1807,13 @@
|
|||
(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))))))))
|
||||
(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))
|
||||
|
|
@ -1836,11 +1836,13 @@
|
|||
(if tmp-1
|
||||
(apply (lambda (e1 e2)
|
||||
(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))))
|
||||
tmp-1)
|
||||
(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)
|
||||
(let ((tmp ($sc-dispatch tmp '())))
|
||||
(if tmp
|
||||
|
|
@ -1858,7 +1860,9 @@
|
|||
(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)))))))))))
|
||||
(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)
|
||||
|
|
@ -1868,7 +1872,8 @@
|
|||
((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))))
|
||||
(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
|
||||
|
|
@ -1904,12 +1909,12 @@
|
|||
(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))))
|
||||
(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
|
||||
(expand-lambda
|
||||
(lambda (e r w s mod)
|
||||
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
|
||||
(if tmp
|
||||
|
|
@ -1919,10 +1924,13 @@
|
|||
(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))
|
||||
(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))))))
|
||||
(append
|
||||
meta
|
||||
(list (cons 'documentation (syntax->datum docstring))))))
|
||||
tmp)
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
|
||||
(if tmp
|
||||
|
|
@ -1932,21 +1940,18 @@
|
|||
(expand-simple-lambda e r w s mod req rest meta body)))))))))
|
||||
tmp)
|
||||
(syntax-violation 'lambda "bad lambda" e)))))
|
||||
(global-extend
|
||||
'core
|
||||
'lambda*
|
||||
(expand-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 ()
|
||||
(expand-lambda-case e r w s mod lambda*-formals (list (cons args (cons e1 e2)))))
|
||||
(lambda (meta lcase) (build-case-lambda s meta lcase))))
|
||||
tmp)
|
||||
(syntax-violation 'lambda "bad lambda*" e)))))
|
||||
(global-extend
|
||||
'core
|
||||
'case-lambda
|
||||
(expand-case-lambda
|
||||
(lambda (e r w s mod)
|
||||
(letrec* ((build-it
|
||||
(lambda (meta clauses)
|
||||
|
|
@ -1958,8 +1963,11 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
||||
(map (lambda (tmp-680b775fb37a463-113f
|
||||
tmp-680b775fb37a463-113e
|
||||
tmp-680b775fb37a463-113d)
|
||||
(cons tmp-680b775fb37a463-113d
|
||||
(cons tmp-680b775fb37a463-113e tmp-680b775fb37a463-113f)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1969,17 +1977,15 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-6ae tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ac)
|
||||
(cons tmp-680b775fb37a463-6ac
|
||||
(cons tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ae)))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463
|
||||
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
tmp)
|
||||
(syntax-violation 'case-lambda "bad case-lambda" e))))))))
|
||||
(global-extend
|
||||
'core
|
||||
'case-lambda*
|
||||
(expand-case-lambda*
|
||||
(lambda (e r w s mod)
|
||||
(letrec* ((build-it
|
||||
(lambda (meta clauses)
|
||||
|
|
@ -2002,16 +2008,17 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
||||
(map (lambda (tmp-680b775fb37a463-118b
|
||||
tmp-680b775fb37a463-118a
|
||||
tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463
|
||||
(cons tmp-680b775fb37a463-118a tmp-680b775fb37a463-118b)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
tmp)
|
||||
(syntax-violation 'case-lambda "bad case-lambda*" e))))))))
|
||||
(global-extend
|
||||
'core
|
||||
'with-ellipsis
|
||||
(expand-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))
|
||||
|
|
@ -2030,9 +2037,7 @@
|
|||
(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
|
||||
(expand-let
|
||||
(letrec* ((expand-let
|
||||
(lambda (e r w s mod constructor ids vals exps)
|
||||
(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)))
|
||||
tmp)
|
||||
(syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
|
||||
(global-extend
|
||||
'core
|
||||
'letrec
|
||||
(expand-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))
|
||||
|
|
@ -2076,9 +2079,7 @@
|
|||
(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*
|
||||
(expand-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))
|
||||
|
|
@ -2097,9 +2098,7 @@
|
|||
(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!
|
||||
(expand-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))
|
||||
|
|
@ -2111,7 +2110,8 @@
|
|||
(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 '(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 empty-wrap mod)
|
||||
|
|
@ -2147,13 +2147,15 @@
|
|||
tmp-1))))))
|
||||
(build-call
|
||||
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)))))))))
|
||||
tmp)
|
||||
(syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
|
||||
(global-extend
|
||||
'module-ref
|
||||
'@
|
||||
(expand-public-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))
|
||||
|
|
@ -2166,16 +2168,18 @@
|
|||
(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
|
||||
'@@
|
||||
(expand-private-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)))
|
||||
(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))
|
||||
|
|
@ -2189,7 +2193,8 @@
|
|||
(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))))
|
||||
(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-wrap #f '(primitive))) tmp-1)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
|
||||
|
|
@ -2215,9 +2220,7 @@
|
|||
(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
|
||||
(expand-if
|
||||
(lambda (e r w s mod)
|
||||
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
|
||||
(if tmp-1
|
||||
|
|
@ -2227,17 +2230,14 @@
|
|||
(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)))
|
||||
(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
|
||||
(expand-syntax-case
|
||||
(letrec* ((convert-pattern
|
||||
(lambda (pattern keys ellipsis?)
|
||||
(letrec* ((cvt* (lambda (p* n ids)
|
||||
|
|
@ -2260,7 +2260,8 @@
|
|||
(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))
|
||||
((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))
|
||||
|
|
@ -2268,10 +2269,13 @@
|
|||
(call-with-values
|
||||
(lambda () (cvt x (#{1+}# n) 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)
|
||||
(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)
|
||||
(call-with-values
|
||||
(lambda () (cvt* ys n ids))
|
||||
|
|
@ -2281,7 +2285,8 @@
|
|||
(lambda (x ids)
|
||||
(call-with-values
|
||||
(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)
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(any . any))))
|
||||
(if tmp-1
|
||||
|
|
@ -2296,7 +2301,9 @@
|
|||
(let ((tmp-1 ($sc-dispatch tmp '())))
|
||||
(if 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
|
||||
(apply (lambda (x)
|
||||
(call-with-values
|
||||
|
|
@ -2324,7 +2331,9 @@
|
|||
exp
|
||||
(extend-env
|
||||
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)
|
||||
(make-binding-wrap ids labels empty-wrap)
|
||||
mod))
|
||||
|
|
@ -2363,7 +2372,10 @@
|
|||
(gen-syntax-case x keys clauses r mod))))
|
||||
(list (if (eq? p 'any)
|
||||
(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
|
||||
(lambda (x keys clauses r mod)
|
||||
(if (null? clauses)
|
||||
|
|
@ -2423,7 +2435,31 @@
|
|||
(list (expand val r empty-wrap mod))))
|
||||
(syntax-violation 'syntax-case "invalid literals list" e)))
|
||||
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
|
||||
(lambda* (x #:optional (m 'e) (esew '(eval)))
|
||||
(letrec* ((unstrip
|
||||
|
|
@ -2802,9 +2838,8 @@
|
|||
#f
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-145f tmp-680b775fb37a463-145e)
|
||||
(list (cons tmp-680b775fb37a463-145e tmp-680b775fb37a463-145f)
|
||||
tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2816,9 +2851,11 @@
|
|||
dots
|
||||
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-149b
|
||||
tmp-680b775fb37a463-149a
|
||||
tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-149a)
|
||||
tmp-680b775fb37a463-149b))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2834,11 +2871,11 @@
|
|||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463-2
|
||||
tmp-680b775fb37a463-1
|
||||
tmp-680b775fb37a463)
|
||||
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
|
||||
tmp-680b775fb37a463-2))
|
||||
(map (lambda (tmp-680b775fb37a463-14ba
|
||||
tmp-680b775fb37a463-14b9
|
||||
tmp-680b775fb37a463-14b8)
|
||||
(list (cons tmp-680b775fb37a463-14b8 tmp-680b775fb37a463-14b9)
|
||||
tmp-680b775fb37a463-14ba))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2993,9 +3030,9 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463-154a)
|
||||
(map (lambda (tmp-680b775fb37a463-156c)
|
||||
(list "value"
|
||||
tmp-680b775fb37a463-154a))
|
||||
tmp-680b775fb37a463-156c))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3135,8 +3172,8 @@
|
|||
(let ((tmp-1 ls))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15ae)
|
||||
(cons "vector" t-680b775fb37a463-15ae))
|
||||
(apply (lambda (t-680b775fb37a463-15d0)
|
||||
(cons "vector" t-680b775fb37a463-15d0))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3146,8 +3183,8 @@
|
|||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (y)
|
||||
(k (map (lambda (tmp-680b775fb37a463-15ba)
|
||||
(list "quote" tmp-680b775fb37a463-15ba))
|
||||
(k (map (lambda (tmp-680b775fb37a463-15dc)
|
||||
(list "quote" tmp-680b775fb37a463-15dc))
|
||||
y)))
|
||||
tmp-1)
|
||||
(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)
|
||||
(let ((else tmp))
|
||||
(let ((tmp x))
|
||||
(let ((t-680b775fb37a463-15c9 tmp))
|
||||
(list "list->vector" t-680b775fb37a463-15c9)))))))))))))))))
|
||||
(let ((t-680b775fb37a463-15eb tmp))
|
||||
(list "list->vector" t-680b775fb37a463-15eb)))))))))))))))))
|
||||
(emit (lambda (x)
|
||||
(let ((tmp x))
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
|
||||
|
|
@ -3171,9 +3208,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15d8)
|
||||
(apply (lambda (t-680b775fb37a463-15fa)
|
||||
(cons (make-syntax 'list '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-15d8))
|
||||
t-680b775fb37a463-15fa))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3189,14 +3226,14 @@
|
|||
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
|
||||
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15ec
|
||||
t-680b775fb37a463-15eb)
|
||||
(apply (lambda (t-680b775fb37a463-160e
|
||||
t-680b775fb37a463-160d)
|
||||
(list (make-syntax
|
||||
'cons
|
||||
'((top))
|
||||
'(hygiene guile))
|
||||
t-680b775fb37a463-15ec
|
||||
t-680b775fb37a463-15eb))
|
||||
t-680b775fb37a463-160e
|
||||
t-680b775fb37a463-160d))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3209,12 +3246,12 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15f8)
|
||||
(apply (lambda (t-680b775fb37a463-161a)
|
||||
(cons (make-syntax
|
||||
'append
|
||||
'((top))
|
||||
'(hygiene guile))
|
||||
t-680b775fb37a463-15f8))
|
||||
t-680b775fb37a463-161a))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
|
|||
|
|
@ -1934,12 +1934,7 @@
|
|||
|
||||
;; core transformers
|
||||
|
||||
(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)
|
||||
(define (expand-syntax-parameterize e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ ((var val) ...) e1 e2 ...)
|
||||
(valid-bound-ids? #'(var ...))
|
||||
|
|
@ -1975,23 +1970,20 @@
|
|||
w
|
||||
mod)))
|
||||
(_ (syntax-violation 'syntax-parameterize "bad syntax"
|
||||
(source-wrap e w s mod))))))
|
||||
(source-wrap e w s mod)))))
|
||||
|
||||
(global-extend 'core 'quote
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-quote e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ e) (build-data s (strip #'e)))
|
||||
(_ (syntax-violation 'quote "bad syntax"
|
||||
(source-wrap e w s mod))))))
|
||||
(source-wrap e w s mod)))))
|
||||
|
||||
(global-extend 'core 'quote-syntax
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-quote-syntax e r w s mod)
|
||||
(syntax-case (source-wrap e w s mod) ()
|
||||
((_ e) (build-data s #'e))
|
||||
(e (syntax-violation 'quote "bad syntax" #'e)))))
|
||||
(e (syntax-violation 'quote "bad syntax" #'e))))
|
||||
|
||||
(global-extend
|
||||
'core 'syntax
|
||||
(define expand-syntax
|
||||
(let ()
|
||||
(define (gen-syntax src e r maps ellipsis? mod)
|
||||
(if (id? e)
|
||||
|
|
@ -2145,8 +2137,7 @@
|
|||
(lambda (e maps) (regen e))))
|
||||
(_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
|
||||
|
||||
(global-extend 'core 'lambda
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-lambda e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ args e1 e2 ...)
|
||||
(call-with-values (lambda () (lambda-formals #'args))
|
||||
|
|
@ -2162,10 +2153,9 @@
|
|||
(lp #'(e1 e2 ...)
|
||||
(append meta (syntax->datum #'((k . v) ...)))))
|
||||
(_ (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*
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-lambda* e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ args e1 e2 ...)
|
||||
(call-with-values
|
||||
|
|
@ -2174,10 +2164,9 @@
|
|||
lambda*-formals #'((args e1 e2 ...))))
|
||||
(lambda (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
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-case-lambda e r w s mod)
|
||||
(define (build-it meta clauses)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
|
|
@ -2194,10 +2183,9 @@
|
|||
(build-it `((documentation
|
||||
. ,(syntax->datum #'docstring)))
|
||||
#'((args e1 e2 ...) ...)))
|
||||
(_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
|
||||
(_ (syntax-violation 'case-lambda "bad case-lambda" e))))
|
||||
|
||||
(global-extend 'core 'case-lambda*
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-case-lambda* e r w s mod)
|
||||
(define (build-it meta clauses)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
|
|
@ -2214,10 +2202,9 @@
|
|||
(build-it `((documentation
|
||||
. ,(syntax->datum #'docstring)))
|
||||
#'((args e1 e2 ...) ...)))
|
||||
(_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
|
||||
(_ (syntax-violation 'case-lambda "bad case-lambda*" e))))
|
||||
|
||||
(global-extend 'core 'with-ellipsis
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-with-ellipsis e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ dots e1 e2 ...)
|
||||
(id? #'dots)
|
||||
|
|
@ -2234,9 +2221,9 @@
|
|||
(nr (extend-env labels bindings r)))
|
||||
(expand-body #'(e1 e2 ...) (source-wrap e nw s mod) nr nw mod)))))
|
||||
(_ (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 ()
|
||||
(define (expand-let e r w s mod constructor ids vals exps)
|
||||
(if (not (valid-bound-ids? ids))
|
||||
|
|
@ -2269,9 +2256,7 @@
|
|||
#'(e1 e2 ...)))
|
||||
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
|
||||
|
||||
|
||||
(global-extend 'core 'letrec
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-letrec e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(and-map id? #'(id ...))
|
||||
|
|
@ -2288,11 +2273,9 @@
|
|||
(map (lambda (x) (expand x r w mod)) #'(val ...))
|
||||
(expand-body #'(e1 e2 ...)
|
||||
(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)))))
|
||||
|
||||
|
||||
(global-extend 'core 'letrec*
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-letrec* e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ ((id val) ...) e1 e2 ...)
|
||||
(and-map id? #'(id ...))
|
||||
|
|
@ -2309,12 +2292,9 @@
|
|||
(map (lambda (x) (expand x r w mod)) #'(val ...))
|
||||
(expand-body #'(e1 e2 ...)
|
||||
(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)))))
|
||||
|
||||
|
||||
(global-extend
|
||||
'core 'set!
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-set! e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ id val)
|
||||
(id? #'id)
|
||||
|
|
@ -2358,10 +2338,9 @@
|
|||
(expand #'(setter head) r w mod)
|
||||
(map (lambda (e) (expand e r w mod))
|
||||
#'(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 '@
|
||||
(lambda (e r w mod)
|
||||
(define (expand-public-ref e r w mod)
|
||||
(syntax-case e ()
|
||||
((_ (mod ...) id)
|
||||
(and (and-map id? #'(mod ...)) (id? #'id))
|
||||
|
|
@ -2369,10 +2348,9 @@
|
|||
;; so that the identifier will not be captured by lexicals.
|
||||
(values (syntax->datum #'id) r top-wrap #f
|
||||
(syntax->datum
|
||||
#'(public mod ...)))))))
|
||||
#'(public mod ...))))))
|
||||
|
||||
(global-extend 'module-ref '@@
|
||||
(lambda (e r w mod)
|
||||
(define (expand-private-ref e r w mod)
|
||||
(define (remodulate x mod)
|
||||
(cond ((pair? x)
|
||||
(cons (remodulate (car x) mod)
|
||||
|
|
@ -2416,10 +2394,9 @@
|
|||
(let ((mod (syntax->datum #'(private mod ...))))
|
||||
(values (remodulate #'exp mod)
|
||||
r w (source-annotation #'exp)
|
||||
mod))))))
|
||||
mod)))))
|
||||
|
||||
(global-extend 'core 'if
|
||||
(lambda (e r w s mod)
|
||||
(define (expand-if e r w s mod)
|
||||
(syntax-case e ()
|
||||
((_ test then)
|
||||
(build-conditional
|
||||
|
|
@ -2432,18 +2409,9 @@
|
|||
s
|
||||
(expand #'test r w mod)
|
||||
(expand #'then r w mod)
|
||||
(expand #'else r w mod))))))
|
||||
(expand #'else r w mod)))))
|
||||
|
||||
(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
|
||||
(define expand-syntax-case
|
||||
(let ()
|
||||
(define (convert-pattern pattern keys ellipsis?)
|
||||
;; accepts pattern & keys
|
||||
|
|
@ -2615,6 +2583,31 @@
|
|||
(list (expand #'val r empty-wrap mod))))
|
||||
(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
|
||||
;; evaluating) and esew (which stands for "eval syntax expanders
|
||||
;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue