[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] branch main updated: psyntax: Separate core expanders fr
From: |
Andy Wingo |
Subject: |
[Guile-commits] branch main updated: psyntax: Separate core expanders from their installation |
Date: |
Mon, 18 Nov 2024 10:55:59 -0500 |
This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new cdf8473b1 psyntax: Separate core expanders from their installation
cdf8473b1 is described below
commit cdf8473b190ac3ed108437974a41d3d990a27b2d
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Nov 18 16:53:41 2024 +0100
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.
---
module/ice-9/psyntax-pp.scm | 1479 ++++++++++++++++++++++---------------------
module/ice-9/psyntax.scm | 1325 +++++++++++++++++++-------------------
2 files changed, 1417 insertions(+), 1387 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 99e904cbe..df6131d31 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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,709 +1721,745 @@
((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls)
((syntax? vars) (lvl (syntax-expression vars) ls
(join-wraps w (syntax-wrap vars))))
- (else (cons vars ls)))))))
- (global-extend 'local-syntax 'letrec-syntax #t)
- (global-extend 'local-syntax 'let-syntax #f)
- (global-extend
- 'core
- 'syntax-parameterize
- (lambda (e r w s mod)
- (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any .
each-any))))
- (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var))
tmp))
- (apply (lambda (var val e1 e2)
- (let ((names (map (lambda (x)
- (call-with-values
- (lambda () (resolve-identifier x w
r mod #f))
- (lambda (type value mod)
- (let ((key type))
- (cond
- ((memv key
'(displaced-lexical))
- (syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap x w s mod)))
- ((memv key
'(syntax-parameter)) value)
- (else (syntax-violation
- 'syntax-parameterize
- "invalid syntax
parameter"
- e
- (source-wrap x w s
mod))))))))
- var))
- (bindings
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (cons 'syntax-parameter
(eval-local-transformer (expand x trans-r w mod) mod)))
- val))))
- (expand-body (cons e1 e2) (source-wrap e w s mod)
(extend-env names bindings r) w mod)))
- tmp)
- (syntax-violation 'syntax-parameterize "bad syntax" (source-wrap
e w s mod))))))
- (global-extend
- 'core
- 'quote
- (lambda (e r w s mod)
- (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
- (if tmp
- (apply (lambda (e) (build-data s (strip e))) 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))))))
- (global-extend
- 'core
- 'syntax
- (letrec* ((gen-syntax
- (lambda (src e r maps ellipsis? mod)
- (if (id? e)
- (call-with-values
- (lambda () (resolve-identifier e empty-wrap r mod #f))
- (lambda (type value mod)
- (let ((key type))
- (cond
- ((memv key '(syntax))
+ (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))
+ (apply (lambda (var val e1 e2)
+ (let ((names (map (lambda (x)
+ (call-with-values
+ (lambda ()
(resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond
+ ((memv key
'(displaced-lexical))
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of
context"
+ e
+ (source-wrap x w s
mod)))
+ ((memv key
'(syntax-parameter)) value)
+ (else
(syntax-violation
+
'syntax-parameterize
+ "invalid
syntax parameter"
+ e
+ (source-wrap x
w s mod))))))))
+ var))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (cons 'syntax-parameter
+ (eval-local-transformer
(expand x trans-r w mod) mod)))
+ val))))
+ (expand-body (cons e1 e2) (source-wrap e w s
mod) (extend-env names bindings r) w mod)))
+ tmp)
+ (syntax-violation 'syntax-parameterize "bad syntax"
(source-wrap e w s mod))))))
+ (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))))))
+ (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))))))
+ (expand-syntax
+ (letrec* ((gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
(call-with-values
- (lambda () (gen-ref src (car value) (cdr value)
maps))
- (lambda (var maps) (values (list 'ref var)
maps))))
- ((ellipsis? e r mod) (syntax-violation 'syntax
"misplaced ellipsis" src))
- (else (values (list 'quote e) maps))))))
- (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
- (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots
r mod)) tmp-1))
- (apply (lambda (dots e) (gen-syntax src e r maps
(lambda (e r mod) #f) mod)) tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
- (if (and tmp-1 (apply (lambda (x dots y)
(ellipsis? dots r mod)) tmp-1))
- (apply (lambda (x dots y)
- (let f ((y y)
- (k (lambda (maps)
- (call-with-values
- (lambda ()
(gen-syntax src x r (cons '() maps) ellipsis? mod))
- (lambda (x maps)
- (if (null? (car
maps))
-
(syntax-violation 'syntax "extra ellipsis" src)
- (values
(gen-map x (car maps)) (cdr maps))))))))
- (let* ((tmp y) (tmp ($sc-dispatch
tmp '(any . any))))
- (if (and tmp (apply (lambda
(dots y) (ellipsis? dots r mod)) tmp))
- (apply (lambda (dots y)
- (f y
- (lambda (maps)
-
(call-with-values
- (lambda ()
(k (cons '() maps)))
- (lambda (x
maps)
- (if (null?
(car maps))
-
(syntax-violation 'syntax "extra ellipsis" src)
-
(values (gen-mappend x (car maps)) (cdr maps))))))))
- tmp)
- (call-with-values
- (lambda () (gen-syntax src
y r maps ellipsis? mod))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
(values (gen-append x y) maps)))))))))
- tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(any .
any))))
- (if tmp-1
- (apply (lambda (x y)
- (call-with-values
- (lambda () (gen-syntax src x
r maps ellipsis? mod))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax
src y r maps ellipsis? mod))
- (lambda (y maps) (values
(gen-cons x y) maps))))))
- tmp-1)
- (let ((tmp-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 (#{1-}# level) (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)))
+ (lambda () (resolve-identifier e empty-wrap r
mod #f))
+ (lambda (type value mod)
+ (let ((key type))
+ (cond
+ ((memv key '(syntax))
+ (call-with-values
+ (lambda () (gen-ref src (car value)
(cdr value) maps))
+ (lambda (var maps) (values (list 'ref
var) maps))))
+ ((ellipsis? e r mod) (syntax-violation
'syntax "misplaced ellipsis" src))
+ (else (values (list 'quote e) maps))))))
+ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any
any))))
+ (if (and tmp-1 (apply (lambda (dots e)
(ellipsis? dots r mod)) tmp-1))
+ (apply (lambda (dots e) (gen-syntax src e
r maps (lambda (e r mod) #f) mod)) tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any any .
any))))
+ (if (and tmp-1 (apply (lambda (x dots y)
(ellipsis? dots r mod)) tmp-1))
+ (apply (lambda (x dots y)
+ (let f ((y y)
+ (k (lambda (maps)
+
(call-with-values
+ (lambda ()
+ (gen-syntax
src x r (cons '() maps) ellipsis? mod))
+ (lambda (x
maps)
+ (if (null?
(car maps))
+
(syntax-violation 'syntax "extra ellipsis" src)
+ (values
(gen-map x (car maps)) (cdr maps))))))))
+ (let* ((tmp y) (tmp
($sc-dispatch tmp '(any . any))))
+ (if (and tmp
+ (apply (lambda
(dots y) (ellipsis? dots r mod)) tmp))
+ (apply (lambda
(dots y)
+ (f y
+ (lambda
(maps)
+
(call-with-values
+
(lambda () (k (cons '() maps)))
+
(lambda (x maps)
+
(if (null? (car maps))
+
(syntax-violation
+
'syntax
+
"extra ellipsis"
+
src)
+
(values
+
(gen-mappend x (car maps))
+
(cdr maps))))))))
+ tmp)
+ (call-with-values
+ (lambda ()
(gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k
maps))
+ (lambda (x
maps) (values (gen-append x y) maps)))))))))
+ tmp-1)
+ (let ((tmp-1 ($sc-dispatch tmp '(any
. any))))
+ (if tmp-1
+ (apply (lambda (x y)
+ (call-with-values
+ (lambda ()
(gen-syntax src x r maps ellipsis? mod))
+ (lambda (x maps)
+ (call-with-values
+ (lambda ()
(gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps)
(values (gen-cons x y) maps))))))
+ tmp-1)
+ (let ((tmp-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
- ((memv key '(ref)) (build-lexical-reference
no-source (cadr x) (cadr x)))
- ((memv key '(primitive)) (build-primref no-source
(cadr x)))
- ((memv key '(quote)) (build-data no-source (cadr
x)))
- ((memv key '(lambda))
- (if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f
(cadr x) '() (regen (caddr x)))
- (error "how did we get here" x)))
- (else (build-primcall no-source (car x) (map regen
(cdr x)))))))))
- (lambda (e r w s mod)
- (let* ((e (source-wrap e w s mod)) (tmp e) (tmp ($sc-dispatch tmp '(_
any))))
- (if tmp
- (apply (lambda (x)
- (call-with-values (lambda () (gen-syntax e x r '()
ellipsis? mod)) (lambda (e maps) (regen e))))
- tmp)
- (syntax-violation 'syntax "bad `syntax' form" e))))))
- (global-extend
- 'core
- 'lambda
- (lambda (e r w s mod)
- (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
- (if tmp
- (apply (lambda (args e1 e2)
- (call-with-values
- (lambda () (lambda-formals args))
- (lambda (req opt rest kw)
- (let lp ((body (cons e1 e2)) (meta '()))
- (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any
any . each-any))))
- (if (and tmp (apply (lambda (docstring e1 e2)
(string? (syntax->datum docstring))) tmp))
- (apply (lambda (docstring e1 e2)
- (lp (cons e1 e2)
- (append meta (list (cons
'documentation (syntax->datum docstring))))))
- tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(#(vector
#(each (any . any))) any . each-any))))
- (if tmp
- (apply (lambda (k v e1 e2)
- (lp (cons e1 e2) (append meta
(syntax->datum (map cons k v)))))
- tmp)
- (expand-simple-lambda e r w s mod req
rest meta body)))))))))
- tmp)
- (syntax-violation 'lambda "bad lambda" e)))))
- (global-extend
- 'core
- 'lambda*
- (lambda (e r w s mod)
- (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
- (if tmp
- (apply (lambda (args e1 e2)
- (call-with-values
- (lambda () (expand-lambda-case e r w s mod
lambda*-formals (list (cons args (cons e1 e2)))))
- (lambda (meta lcase) (build-case-lambda s meta lcase))))
- tmp)
- (syntax-violation 'lambda "bad lambda*" e)))))
- (global-extend
- 'core
- 'case-lambda
- (lambda (e r w s mod)
- (letrec* ((build-it
- (lambda (meta clauses)
- (call-with-values
- (lambda () (expand-lambda-case e r w s mod lambda-formals
clauses))
- (lambda (meta* lcase) (build-case-lambda s (append meta
meta*) lcase))))))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any .
each-any))))))
- (if tmp
- (apply (lambda (args e1 e2)
- (build-it
- '()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
- 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-6ae
tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ac)
- (cons tmp-680b775fb37a463-6ac
- (cons tmp-680b775fb37a463-6ad
tmp-680b775fb37a463-6ae)))
- e2
- e1
- args)))
- tmp)
- (syntax-violation 'case-lambda "bad case-lambda" e))))))))
- (global-extend
- 'core
- 'case-lambda*
- (lambda (e r w s mod)
- (letrec* ((build-it
- (lambda (meta clauses)
- (call-with-values
- (lambda () (expand-lambda-case e r w s mod
lambda*-formals clauses))
- (lambda (meta* lcase) (build-case-lambda s (append meta
meta*) lcase))))))
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any .
each-any))))))
- (if tmp
- (apply (lambda (args e1 e2)
- (build-it
- '()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
- 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-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
- e2
- e1
- args)))
+ ((= level 0) (values var maps))
+ ((null? maps) (syntax-violation 'syntax "missing
ellipsis" src))
+ (else (call-with-values
+ (lambda () (gen-ref src var (#{1-}# level)
(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 no-source (cadr x) (cadr x)))
+ ((memv key '(primitive)) (build-primref
no-source (cadr x)))
+ ((memv key '(quote)) (build-data no-source
(cadr x)))
+ ((memv key '(lambda))
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr
x) #f (cadr x) '() (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-primcall no-source (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))))))
+ (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 () (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 '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))))))
- (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)))
+ (syntax-violation 'lambda "bad lambda" e)))))
+ (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 (meta lcase) (build-case-lambda s meta
lcase))))
tmp)
- (syntax-violation 'let "bad let" (source-wrap e w s
mod)))))))))
- (global-extend
- 'core
- 'letrec
- (lambda (e r w s mod)
- (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any .
each-any))))
- (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
- (apply (lambda (id val e1 e2)
- (let ((ids id))
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'letrec "duplicate bound
variable" e)
- (let ((labels (gen-labels ids)) (new-vars (map
gen-var ids)))
- (let ((w (make-binding-wrap ids labels w)) (r
(extend-var-env labels new-vars r)))
- (build-letrec
- s
- #f
- (map syntax->datum ids)
- new-vars
- (map (lambda (x) (expand x r w mod)) val)
- (expand-body (cons e1 e2) (source-wrap e w s
mod) r w mod)))))))
- tmp)
- (syntax-violation 'letrec "bad letrec" (source-wrap e w s
mod))))))
- (global-extend
- 'core
- 'letrec*
- (lambda (e r w s mod)
- (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any .
each-any))))
- (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
- (apply (lambda (id val e1 e2)
- (let ((ids id))
- (if (not (valid-bound-ids? ids))
- (syntax-violation 'letrec* "duplicate bound
variable" e)
- (let ((labels (gen-labels ids)) (new-vars (map
gen-var ids)))
- (let ((w (make-binding-wrap ids labels w)) (r
(extend-var-env labels new-vars r)))
- (build-letrec
- s
- #t
- (map syntax->datum ids)
- new-vars
- (map (lambda (x) (expand x r w mod)) val)
- (expand-body (cons e1 e2) (source-wrap e w s
mod) r w mod)))))))
- tmp)
- (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s
mod))))))
- (global-extend
- 'core
- 'set!
- (lambda (e r w s mod)
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
- (if (and tmp (apply (lambda (id val) (id? id)) tmp))
- (apply (lambda (id val)
- (call-with-values
- (lambda () (resolve-identifier id w r mod #t))
- (lambda (type value id-mod)
- (let ((key type))
- (cond
- ((memv key '(lexical))
- (build-lexical-assignment s (syntax->datum id)
value (expand val r w mod)))
- ((memv key '(global)) (build-global-assignment s
value (expand val r w mod) id-mod))
- ((memv key '(macro))
- (if (procedure-property value
'variable-transformer)
- (expand (expand-macro value e r w s #f mod)
r empty-wrap 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)
+ (syntax-violation 'lambda "bad lambda*" e)))))
+ (expand-case-lambda
+ (lambda (e r w s mod)
+ (letrec* ((build-it
+ (lambda (meta clauses)
(call-with-values
- (lambda () (syntax-type head r empty-wrap
no-source #f mod #t))
- (lambda (type value ee* ee ww ss modmod)
- (let ((key type))
- (if (memv key '(module-ref))
- (let ((val (expand val r w mod)))
- (call-with-values
- (lambda () (value (cons head tail) r w
mod))
- (lambda (e r w s* mod)
- (let* ((tmp-1 e) (tmp (list tmp-1)))
- (if (and tmp (apply (lambda (e)
(id? e)) tmp))
- (apply (lambda (e)
-
(build-global-assignment s (syntax->datum e) val mod))
- tmp)
- (syntax-violation
- #f
- "source expression failed to
match any pattern"
- tmp-1))))))
- (build-call
- s
- (expand (list (make-syntax 'setter
'((top)) '(hygiene guile)) head) r w mod)
- (map (lambda (e) (expand e r w mod))
(append tail (list val)))))))))
- tmp)
- (syntax-violation 'set! "bad set!" (source-wrap e w s
mod))))))))
- (global-extend
- 'module-ref
- '@
- (lambda (e r w mod)
- (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
- (if (and tmp (apply (lambda (mod id) (and (and-map id? mod) (id?
id))) tmp))
- (apply (lambda (mod id)
- (values
- (syntax->datum id)
- r
- top-wrap
- #f
- (syntax->datum (cons (make-syntax 'public '((top))
'(hygiene guile)) mod))))
- tmp)
- (syntax-violation #f "source expression failed to match any
pattern" tmp-1)))))
- (global-extend
- 'module-ref
- '@@
- (lambda (e r w mod)
- (letrec* ((remodulate
- (lambda (x mod)
- (cond
- ((pair? x) (cons (remodulate (car x) mod) (remodulate
(cdr x) mod)))
- ((syntax? x)
- (make-syntax (remodulate (syntax-expression x) mod)
(syntax-wrap x) mod (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 (#{1+}# i)))))))
- (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-wrap #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))
+ (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-113f
+ tmp-680b775fb37a463-113e
+ tmp-680b775fb37a463-113d)
+ (cons tmp-680b775fb37a463-113d
+ (cons tmp-680b775fb37a463-113e
tmp-680b775fb37a463-113f)))
+ 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-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))))))))
+ (expand-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-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ 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-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))))))))
+ (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))
+ (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))))))
+ (expand-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)))))))))
+ (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))
+ (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))))))
+ (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))
+ (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))))))
+ (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))
+ (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 empty-wrap 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 empty-wrap
no-source #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))))))))
+ (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))
(apply (lambda (mod id)
(values
(syntax->datum id)
r
top-wrap
#f
- (syntax->datum (cons (make-syntax 'private
'((top)) '(hygiene guile)) mod))))
+ (syntax->datum (cons (make-syntax 'public
'((top)) '(hygiene guile)) mod))))
+ tmp)
+ (syntax-violation #f "source expression failed to match
any pattern" tmp-1)))))
+ (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)))
+ ((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 (#{1+}# i)))))))
+ (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-wrap #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-wrap
+ #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))))))))))
+ (expand-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 no-source)))
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)))
+ (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
- '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 no-source)))
- 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)))))))
+ (syntax-violation #f "source expression failed to
match any pattern" tmp)))))))
+ (expand-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 (#{1+}# n) ids))
+ (lambda (p ids)
+ (values
+ (if (eq? p
'any) 'each-any (vector 'each p))
+ ids))))
+ tmp-1)
+ (let ((tmp-1
($sc-dispatch tmp '(any any . any))))
+ (if (and tmp-1
+ (apply (lambda
(x dots ys) (ellipsis? dots)) tmp-1))
+ (apply (lambda (x
dots ys)
+
(call-with-values
+ (lambda
() (cvt* ys n ids))
+ (lambda
(ys ids)
+
(call-with-values
+
(lambda () (cvt x (+ n 1) ids))
+
(lambda (x ids)
+
(call-with-values
+
(lambda () (v-reverse ys))
+
(lambda (ys e)
+
(values (vector 'each+ x ys e) ids))))))))
+ tmp-1)
+ (let ((tmp-1
($sc-dispatch tmp '(any . any))))
+ (if tmp-1
+ (apply
(lambda (x y)
+
(call-with-values
+
(lambda () (cvt y n ids))
+
(lambda (y ids)
+
(call-with-values
+
(lambda () (cvt x n ids))
+
(lambda (x ids) (values (cons x y) ids))))))
+ tmp-1)
+ (let ((tmp-1
($sc-dispatch tmp '())))
+ (if tmp-1
+ (apply
(lambda () (values '() ids)) tmp-1)
+ (let
((tmp-1 ($sc-dispatch
+
tmp
+
'#(vector each-any))))
+ (if
tmp-1
+
(apply (lambda (x)
+
(call-with-values
+
(lambda () (cvt x n ids))
+
(lambda (p ids)
+
(values (vector 'vector p) ids))))
+
tmp-1)
+
(let ((x tmp))
+
(values (vector 'atom (strip p)) ids))))))))))))))))
+ (cvt pattern 0 '()))))
+ (build-dispatch-call
+ (lambda (pvars exp y r mod)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map
gen-var ids)))
+ (build-primcall
+ no-source
+ 'apply
+ (list (build-simple-lambda
+ no-source
+ (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
empty-wrap)
+ 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
+ no-source
+ (build-simple-lambda
+ no-source
+ (list 'tmp)
+ #f
+ (list y)
+ '()
+ (let ((y (build-lexical-reference
no-source 'tmp y)))
+ (build-conditional
+ no-source
+ (let* ((tmp fender) (tmp
($sc-dispatch tmp '#(atom #t))))
+ (if tmp
+ (apply (lambda () y) tmp)
+ (build-conditional
+ no-source
+ y
+ (build-dispatch-call pvars
fender y r mod)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r
mod)
+ (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)))))))))))))
+ (gen-syntax-case
+ (lambda (x keys clauses r mod)
+ (if (null? clauses)
+ (build-primcall
+ no-source
+ 'syntax-violation
+ (list (build-data no-source #f)
+ (build-data no-source "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 empty-wrap
mod)
+ (let ((labels (list
(gen-label))) (var (gen-var pat)))
+ (build-call
+ no-source
+ (build-simple-lambda
+ no-source
+ (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 empty-wrap)
+ 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
+ no-source
+ (list 'tmp)
+ #f
+ (list x)
+ '()
+ (gen-syntax-case
(build-lexical-reference no-source 'tmp x) key m r mod))
+ (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)))))))
+ (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
- (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
(#{1+}# n) ids))
- (lambda (p ids)
- (values (if (eq? p
'any) 'each-any (vector 'each p)) ids))))
- tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp
'(any any . any))))
- (if (and tmp-1 (apply (lambda
(x dots ys) (ellipsis? dots)) tmp-1))
- (apply (lambda (x dots ys)
- (call-with-values
- (lambda () (cvt*
ys n ids))
- (lambda (ys ids)
-
(call-with-values
- (lambda ()
(cvt x (+ n 1) ids))
- (lambda (x ids)
-
(call-with-values
- (lambda ()
(v-reverse ys))
- (lambda (ys
e) (values (vector 'each+ x ys e) ids))))))))
- tmp-1)
- (let ((tmp-1 ($sc-dispatch
tmp '(any . any))))
- (if tmp-1
- (apply (lambda (x y)
-
(call-with-values
- (lambda ()
(cvt y n ids))
- (lambda (y
ids)
-
(call-with-values
- (lambda
() (cvt x n ids))
- (lambda
(x ids) (values (cons x y) ids))))))
- tmp-1)
- (let ((tmp-1
($sc-dispatch tmp '())))
- (if tmp-1
- (apply (lambda
() (values '() ids)) tmp-1)
- (let ((tmp-1
($sc-dispatch tmp '#(vector each-any))))
- (if tmp-1
- (apply
(lambda (x)
-
(call-with-values
-
(lambda () (cvt x n ids))
-
(lambda (p ids)
-
(values (vector 'vector p) ids))))
-
tmp-1)
- (let ((x
tmp))
- (values
(vector 'atom (strip p)) ids))))))))))))))))
- (cvt pattern 0 '()))))
- (build-dispatch-call
- (lambda (pvars exp y r mod)
- (let ((ids (map car pvars)) (levels (map cdr pvars)))
- (let ((labels (gen-labels ids)) (new-vars (map gen-var
ids)))
- (build-primcall
- no-source
- 'apply
- (list (build-simple-lambda
- no-source
- (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 empty-wrap)
- 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
- no-source
- (build-simple-lambda
- no-source
- (list 'tmp)
- #f
- (list y)
- '()
- (let ((y (build-lexical-reference no-source
'tmp y)))
- (build-conditional
- no-source
- (let* ((tmp fender) (tmp ($sc-dispatch tmp
'#(atom #t))))
- (if tmp
- (apply (lambda () y) tmp)
- (build-conditional
- no-source
- y
- (build-dispatch-call pvars fender y
r mod)
- (build-data no-source #f))))
- (build-dispatch-call pvars exp y r mod)
- (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)))))))))))))
- (gen-syntax-case
- (lambda (x keys clauses r mod)
- (if (null? clauses)
- (build-primcall
- no-source
- 'syntax-violation
- (list (build-data no-source #f)
- (build-data no-source "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 empty-wrap mod)
- (let ((labels (list (gen-label)))
(var (gen-var pat)))
- (build-call
- no-source
- (build-simple-lambda
- no-source
- (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 empty-wrap)
- 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
- no-source
- (list 'tmp)
- #f
- (list x)
- '()
- (gen-syntax-case (build-lexical-reference
no-source 'tmp x) key m r mod))
- (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))))))
+ (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
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 110d46da5..147f2ff84 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1934,686 +1934,679 @@
;; core transformers
- (global-extend 'local-syntax 'letrec-syntax #t)
- (global-extend 'local-syntax 'let-syntax #f)
+ (define (expand-syntax-parameterize e r w s mod)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? #'(var ...))
+ (let ((names
+ (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((displaced-lexical)
+ (syntax-violation 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((syntax-parameter)
+ value)
+ (else
+ (syntax-violation 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod)))))))
+ #'(var ...)))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding
+ 'syntax-parameter
+ (eval-local-transformer (expand x trans-r w mod) mod)))
+ #'(val ...)))))
+ (expand-body #'(e1 e2 ...)
+ (source-wrap e w s mod)
+ (extend-env names bindings r)
+ w
+ mod)))
+ (_ (syntax-violation 'syntax-parameterize "bad syntax"
+ (source-wrap e w s mod)))))
- (global-extend
- 'core 'syntax-parameterize
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? #'(var ...))
- (let ((names
- (map (lambda (x)
- (call-with-values
- (lambda () (resolve-identifier x w r mod #f))
- (lambda (type value mod)
- (case type
- ((displaced-lexical)
- (syntax-violation 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap x w s mod)))
- ((syntax-parameter)
- value)
- (else
- (syntax-violation 'syntax-parameterize
- "invalid syntax parameter"
- e
- (source-wrap x w s mod)))))))
- #'(var ...)))
- (bindings
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding
- 'syntax-parameter
- (eval-local-transformer (expand x trans-r w mod)
mod)))
- #'(val ...)))))
- (expand-body #'(e1 e2 ...)
- (source-wrap e w s mod)
- (extend-env names bindings r)
- w
- mod)))
- (_ (syntax-violation 'syntax-parameterize "bad syntax"
- (source-wrap e w s mod))))))
-
- (global-extend 'core 'quote
- (lambda (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))))))
+ (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)))))
- (global-extend 'core 'quote-syntax
- (lambda (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)))))
-
- (global-extend
- 'core 'syntax
- (let ()
- (define (gen-syntax src e r maps ellipsis? mod)
- (if (id? e)
- (call-with-values (lambda ()
- (resolve-identifier e empty-wrap r mod #f))
- (lambda (type value mod)
- (case type
- ((syntax)
- (call-with-values
- (lambda () (gen-ref src (car value) (cdr value) maps))
- (lambda (var maps)
- (values `(ref ,var) maps))))
- (else
- (if (ellipsis? e r mod)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps))))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? #'dots r mod)
- (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
- ((x dots . y)
- ;; this could be about a dozen lines of code, except that we
- ;; choose to handle #'(x ... ...) forms
- (ellipsis? #'dots r mod)
- (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))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? #'dots r mod)
- (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))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis? mod))
- (lambda (y maps)
+ (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))))
+
+ (define expand-syntax
+ (let ()
+ (define (gen-syntax src e r maps ellipsis? mod)
+ (if (id? e)
+ (call-with-values (lambda ()
+ (resolve-identifier e empty-wrap r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((syntax)
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps)
+ (values `(ref ,var) maps))))
+ (else
+ (if (ellipsis? e r mod)
+ (syntax-violation 'syntax "misplaced ellipsis" src)
+ (values `(quote ,e) maps))))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots r mod)
+ (gen-syntax src #'e r maps (lambda (e r mod) #f) mod))
+ ((x dots . y)
+ ;; this could be about a dozen lines of code, except that we
+ ;; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots r mod)
+ (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))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? #'dots r mod)
+ (f #'y
+ (lambda (maps)
(call-with-values
- (lambda () (k maps))
+ (lambda () (k (cons '() maps)))
(lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((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))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
- (lambda (e maps) (values (gen-vector e) maps))))
- (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps))
- (() (values '(quote ()) maps))
- (_ (values `(quote ,e) maps)))))
-
- (define (gen-ref src var level maps)
- (if (= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-violation 'syntax "missing ellipsis" src)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis"
src)
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (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)))))))))
+ ((x . y)
(call-with-values
- (lambda () (gen-ref src var (1- level) (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))))))))))
-
- (define (gen-mappend e map-env)
- `(apply (primitive append) ,(gen-map e map-env)))
-
- (define (gen-map e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ;; identity map equivalence:
- ;; (map (lambda (x) x) y) == y
- (car actuals))
- ((and-map
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ;; eta map equivalence:
- ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals)))))
-
- (define (gen-cons x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y))))
-
- (define (gen-append x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y)))
-
- (define (gen-vector x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x))))
-
-
- (define (regen x)
- (case (car x)
- ((ref) (build-lexical-reference no-source (cadr x) (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda)
- (if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen
(caddr x)))
- (error "how did we get here" x)))
- (else (build-primcall no-source (car x) (map regen (cdr x))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ x)
- (call-with-values
- (lambda () (gen-syntax e #'x r '() ellipsis? mod))
- (lambda (e maps) (regen e))))
- (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
-
- (global-extend 'core 'lambda
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ args e1 e2 ...)
- (call-with-values (lambda () (lambda-formals #'args))
- (lambda (req opt rest kw)
- (let lp ((body #'(e1 e2 ...)) (meta '()))
- (syntax-case body ()
- ((docstring e1 e2 ...) (string? (syntax->datum
#'docstring))
- (lp #'(e1 e2 ...)
- (append meta
- `((documentation
- . ,(syntax->datum
#'docstring))))))
- ((#((k . v) ...) e1 e2 ...)
- (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)))))
+ (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))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (x (eq? (syntax->datum #'x) #nil) (values '(quote #nil) maps))
+ (() (values '(quote ()) maps))
+ (_ (values `(quote ,e) maps)))))
+
+ (define (gen-ref src var level maps)
+ (if (= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-violation 'syntax "missing ellipsis" src)
+ (call-with-values
+ (lambda () (gen-ref src var (1- level) (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))))))))))
+
+ (define (gen-mappend e map-env)
+ `(apply (primitive append) ,(gen-map e map-env)))
+
+ (define (gen-map e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ;; identity map equivalence:
+ ;; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ;; eta map equivalence:
+ ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals)))))
+
+ (define (gen-cons x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y))))
+
+ (define (gen-append x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y)))
+
+ (define (gen-vector x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x))))
+
+
+ (define (regen x)
+ (case (car x)
+ ((ref) (build-lexical-reference no-source (cadr x) (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen
(caddr x)))
+ (error "how did we get here" x)))
+ (else (build-primcall no-source (car x) (map regen (cdr x))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e #'x r '() ellipsis? mod))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+
+ (define (expand-lambda e r w s mod)
+ (syntax-case e ()
+ ((_ args e1 e2 ...)
+ (call-with-values (lambda () (lambda-formals #'args))
+ (lambda (req opt rest kw)
+ (let lp ((body #'(e1 e2 ...)) (meta '()))
+ (syntax-case body ()
+ ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
+ (lp #'(e1 e2 ...)
+ (append meta
+ `((documentation
+ . ,(syntax->datum #'docstring))))))
+ ((#((k . v) ...) e1 e2 ...)
+ (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))))
- (global-extend 'core 'lambda*
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ args e1 e2 ...)
- (call-with-values
- (lambda ()
- (expand-lambda-case e r w s mod
- lambda*-formals #'((args e1 e2
...))))
- (lambda (meta lcase)
- (build-case-lambda s meta lcase))))
- (_ (syntax-violation 'lambda "bad lambda*" e)))))
+ (define (expand-lambda* e r w s mod)
+ (syntax-case e ()
+ ((_ args e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (expand-lambda-case e r w s mod
+ lambda*-formals #'((args e1 e2 ...))))
+ (lambda (meta lcase)
+ (build-case-lambda s meta lcase))))
+ (_ (syntax-violation 'lambda "bad lambda*" e))))
+
+ (define (expand-case-lambda e r w s mod)
+ (define (build-it 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))))
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) ...)
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
+ (_ (syntax-violation 'case-lambda "bad case-lambda" e))))
+
+ (define (expand-case-lambda* e r w s mod)
+ (define (build-it 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))))
+ (syntax-case e ()
+ ((_ (args e1 e2 ...) ...)
+ (build-it '() #'((args e1 e2 ...) ...)))
+ ((_ docstring (args e1 e2 ...) ...)
+ (string? (syntax->datum #'docstring))
+ (build-it `((documentation
+ . ,(syntax->datum #'docstring)))
+ #'((args e1 e2 ...) ...)))
+ (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))
- (global-extend 'core 'case-lambda
- (lambda (e r w s mod)
- (define (build-it 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))))
- (syntax-case e ()
- ((_ (args e1 e2 ...) ...)
- (build-it '() #'((args e1 e2 ...) ...)))
- ((_ docstring (args e1 e2 ...) ...)
- (string? (syntax->datum #'docstring))
- (build-it `((documentation
- . ,(syntax->datum #'docstring)))
- #'((args e1 e2 ...) ...)))
- (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
-
- (global-extend 'core 'case-lambda*
- (lambda (e r w s mod)
- (define (build-it 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))))
- (syntax-case e ()
- ((_ (args e1 e2 ...) ...)
- (build-it '() #'((args e1 e2 ...) ...)))
- ((_ docstring (args e1 e2 ...) ...)
- (string? (syntax->datum #'docstring))
- (build-it `((documentation
- . ,(syntax->datum #'docstring)))
- #'((args e1 e2 ...) ...)))
- (_ (syntax-violation 'case-lambda "bad case-lambda*"
e)))))
-
- (global-extend 'core 'with-ellipsis
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ dots e1 e2 ...)
- (id? #'dots)
- (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 (make-binding 'ellipsis
(source-wrap #'dots w s mod)))))
- (let ((nw (make-binding-wrap ids labels w))
- (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))))))
-
- (global-extend 'core 'let
- (let ()
- (define (expand-let 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)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (and-map id? #'(id ...))
- (expand-let e r w s mod
- build-let
- #'(id ...)
- #'(val ...)
- #'(e1 e2 ...)))
- ((_ f ((id val) ...) e1 e2 ...)
- (and (id? #'f) (and-map id? #'(id ...)))
- (expand-let e r w s mod
- build-named-let
- #'(f id ...)
- #'(val ...)
- #'(e1 e2 ...)))
- (_ (syntax-violation 'let "bad let" (source-wrap e w s
mod)))))))
-
-
- (global-extend 'core 'letrec
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (and-map id? #'(id ...))
- (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 #'(e1 e2 ...)
- (source-wrap e w s
mod) r w mod)))))))
- (_ (syntax-violation 'letrec "bad letrec" (source-wrap e
w s mod))))))
-
-
- (global-extend 'core 'letrec*
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((id val) ...) e1 e2 ...)
- (and-map id? #'(id ...))
- (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 #'(e1 e2 ...)
- (source-wrap e w s
mod) r w mod)))))))
- (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap
e w s mod))))))
-
-
- (global-extend
- 'core 'set!
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ id val)
- (id? #'id)
- (call-with-values
- (lambda () (resolve-identifier #'id w r mod #t))
- (lambda (type value id-mod)
- (case type
- ((lexical)
- (build-lexical-assignment s (syntax->datum #'id) value
- (expand #'val r w mod)))
- ((global)
- (build-global-assignment s value (expand #'val r w mod) id-mod))
- ((macro)
- (if (procedure-property value 'variable-transformer)
- ;; As syntax-type does, call expand-macro with
- ;; the mod of the expression. Hmm.
- (expand (expand-macro value e r w s #f mod) r empty-wrap
mod)
- (syntax-violation 'set! "not a variable transformer"
- (wrap e w mod)
- (wrap #'id w id-mod))))
- ((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)))))))
- ((_ (head tail ...) val)
+ (define (expand-with-ellipsis e r w s mod)
+ (syntax-case e ()
+ ((_ dots e1 e2 ...)
+ (id? #'dots)
+ (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 (make-binding 'ellipsis (source-wrap #'dots w s
mod)))))
+ (let ((nw (make-binding-wrap ids labels w))
+ (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)))))
+
+ (define expand-let
+ (let ()
+ (define (expand-let 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)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (and-map id? #'(id ...))
+ (expand-let e r w s mod
+ build-let
+ #'(id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
+ ((_ f ((id val) ...) e1 e2 ...)
+ (and (id? #'f) (and-map id? #'(id ...)))
+ (expand-let e r w s mod
+ build-named-let
+ #'(f id ...)
+ #'(val ...)
+ #'(e1 e2 ...)))
+ (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
+
+ (define (expand-letrec e r w s mod)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (and-map id? #'(id ...))
+ (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 #'(e1 e2 ...)
+ (source-wrap e w s mod) r w
mod)))))))
+ (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))
+
+ (define (expand-letrec* e r w s mod)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (and-map id? #'(id ...))
+ (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 #'(e1 e2 ...)
+ (source-wrap e w s mod) r w
mod)))))))
+ (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))
+
+ (define (expand-set! e r w s mod)
+ (syntax-case e ()
+ ((_ id val)
+ (id? #'id)
+ (call-with-values
+ (lambda () (resolve-identifier #'id w r mod #t))
+ (lambda (type value id-mod)
+ (case type
+ ((lexical)
+ (build-lexical-assignment s (syntax->datum #'id) value
+ (expand #'val r w mod)))
+ ((global)
+ (build-global-assignment s value (expand #'val r w mod) id-mod))
+ ((macro)
+ (if (procedure-property value 'variable-transformer)
+ ;; As syntax-type does, call expand-macro with
+ ;; the mod of the expression. Hmm.
+ (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
+ (syntax-violation 'set! "not a variable transformer"
+ (wrap e w mod)
+ (wrap #'id w id-mod))))
+ ((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)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
+ (lambda (type value ee* ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (expand #'val r w mod)))
+ (call-with-values (lambda () (value #'(head tail ...) r w mod))
+ (lambda (e r w s* mod)
+ (syntax-case e ()
+ (e (id? #'e)
+ (build-global-assignment s (syntax->datum #'e)
+ val mod)))))))
+ (else
+ (build-call s
+ (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)))))
+
+ (define (expand-public-ref e r w mod)
+ (syntax-case e ()
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
+ (syntax->datum
+ #'(public mod ...))))))
+
+ (define (expand-private-ref e r w mod)
+ (define (remodulate 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)
+ ;; hither the remodulation
+ mod
+ (syntax-sourcev x)))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (do ((i 0 (1+ i)))
+ ((= i n) v)
+ (vector-set! v i (remodulate (vector-ref x i) mod)))))
+ (else x)))
+ (syntax-case e (@@ primitive)
+ ((_ primitive id)
+ (and (id? #'id)
+ (equal? (cdr (or (and (syntax? #'id)
+ (syntax-module #'id))
+ mod))
+ '(guile)))
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f '(primitive)))
+ ((_ (mod ...) id)
+ (and (and-map id? #'(mod ...)) (id? #'id))
+ ;; Strip the wrap from the identifier and return top-wrap
+ ;; so that the identifier will not be captured by lexicals.
+ (values (syntax->datum #'id) r top-wrap #f
+ (syntax->datum
+ #'(private mod ...))))
+ ((_ @@ (mod ...) exp)
+ (and-map id? #'(mod ...))
+ ;; This is a special syntax used to support R6RS library forms.
+ ;; Unlike the syntax above, the last item is not restricted to
+ ;; be a single identifier, and the syntax objects are kept
+ ;; intact, with only their module changed.
+ (let ((mod (syntax->datum #'(private mod ...))))
+ (values (remodulate #'exp mod)
+ r w (source-annotation #'exp)
+ mod)))))
+
+ (define (expand-if e r w s mod)
+ (syntax-case e ()
+ ((_ test then)
+ (build-conditional
+ s
+ (expand #'test r w mod)
+ (expand #'then r w mod)
+ (build-void no-source)))
+ ((_ test then else)
+ (build-conditional
+ s
+ (expand #'test r w mod)
+ (expand #'then r w mod)
+ (expand #'else r w mod)))))
+
+ (define expand-syntax-case
+ (let ()
+ (define (convert-pattern pattern keys ellipsis?)
+ ;; accepts pattern & keys
+ ;; returns $sc-dispatch pattern & ids
+ (define cvt*
+ (lambda (p* n ids)
+ (syntax-case p* ()
+ ((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))))))
+ (_ (cvt p* n ids)))))
+
+ (define (v-reverse x)
+ (let loop ((r '()) (x x))
+ (if (not (pair? x))
+ (values r x)
+ (loop (cons (car x) r) (cdr x)))))
+
+ (define cvt
+ (lambda (p n ids)
+ (if (id? p)
+ (cond
+ ((bound-id-member? p keys)
+ (values (vector 'free-id p) ids))
+ ((free-id=? p #'_)
+ (values '_ ids))
+ (else
+ (values 'any (cons (cons p n) ids))))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? (syntax dots))
+ (call-with-values
+ (lambda () (cvt (syntax x) (1+ n) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector 'each p))
+ ids))))
+ ((x dots . ys)
+ (ellipsis? (syntax dots))
+ (call-with-values
+ (lambda () (cvt* (syntax ys) n ids))
+ (lambda (ys ids)
+ (call-with-values
+ (lambda () (cvt (syntax x) (+ n 1) ids))
+ (lambda (x ids)
+ (call-with-values
+ (lambda () (v-reverse ys))
+ (lambda (ys e)
+ (values `#(each+ ,x ,ys ,e)
+ ids))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt (syntax y) n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt (syntax x) n ids))
+ (lambda (x ids)
+ (values (cons x y) ids))))))
+ (() (values '() ids))
+ (#(x ...)
+ (call-with-values
+ (lambda () (cvt (syntax (x ...)) n ids))
+ (lambda (p ids) (values (vector 'vector p) ids))))
+ (x (values (vector 'atom (strip p)) ids))))))
+ (cvt pattern 0 '()))
+
+ (define (build-dispatch-call 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
+ no-source
+ 'apply
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f
new-vars '()
+ (expand exp
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax
`(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels
empty-wrap)
+ mod))
+ y)))))
+
+ (define (gen-clause x keys clauses r pat fender exp mod)
(call-with-values
- (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
- (lambda (type value ee* ee ww ss modmod)
- (case type
- ((module-ref)
- (let ((val (expand #'val r w mod)))
- (call-with-values (lambda () (value #'(head tail ...) r w
mod))
- (lambda (e r w s* mod)
- (syntax-case e ()
- (e (id? #'e)
- (build-global-assignment s (syntax->datum #'e)
- val mod)))))))
- (else
- (build-call s
- (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))))))
-
- (global-extend 'module-ref '@
- (lambda (e r w mod)
- (syntax-case e ()
- ((_ (mod ...) id)
- (and (and-map id? #'(mod ...)) (id? #'id))
- ;; Strip the wrap from the identifier and return top-wrap
- ;; so that the identifier will not be captured by
lexicals.
- (values (syntax->datum #'id) r top-wrap #f
- (syntax->datum
- #'(public mod ...)))))))
-
- (global-extend 'module-ref '@@
- (lambda (e r w mod)
- (define (remodulate 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)
- ;; hither the remodulation
- mod
- (syntax-sourcev x)))
- ((vector? x)
- (let* ((n (vector-length x)) (v (make-vector n)))
- (do ((i 0 (1+ i)))
- ((= i n) v)
- (vector-set! v i (remodulate (vector-ref x i)
mod)))))
- (else x)))
- (syntax-case e (@@ primitive)
- ((_ primitive id)
- (and (id? #'id)
- (equal? (cdr (or (and (syntax? #'id)
- (syntax-module #'id))
- mod))
- '(guile)))
- ;; Strip the wrap from the identifier and return top-wrap
- ;; so that the identifier will not be captured by
lexicals.
- (values (syntax->datum #'id) r top-wrap #f '(primitive)))
- ((_ (mod ...) id)
- (and (and-map id? #'(mod ...)) (id? #'id))
- ;; Strip the wrap from the identifier and return top-wrap
- ;; so that the identifier will not be captured by
lexicals.
- (values (syntax->datum #'id) r top-wrap #f
- (syntax->datum
- #'(private mod ...))))
- ((_ @@ (mod ...) exp)
- (and-map id? #'(mod ...))
- ;; This is a special syntax used to support R6RS library
forms.
- ;; Unlike the syntax above, the last item is not
restricted to
- ;; be a single identifier, and the syntax objects are
kept
- ;; intact, with only their module changed.
- (let ((mod (syntax->datum #'(private mod ...))))
- (values (remodulate #'exp mod)
- r w (source-annotation #'exp)
- mod))))))
-
- (global-extend 'core 'if
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ test then)
- (build-conditional
- s
- (expand #'test r w mod)
- (expand #'then r w mod)
- (build-void no-source)))
- ((_ test then else)
- (build-conditional
- s
- (expand #'test r w mod)
- (expand #'then r w mod)
- (expand #'else r w mod))))))
+ (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)))
+ ;; fat finger binding and references to temp variable y
+ (build-call no-source
+ (build-simple-lambda no-source (list 'tmp) #f
(list y) '()
+ (let ((y
(build-lexical-reference no-source 'tmp y)))
+ (build-conditional no-source
+
(syntax-case fender ()
+ (#t y)
+ (_
(build-conditional no-source
+
y
+
(build-dispatch-call pvars fender y r mod)
+
(build-data no-source #f))))
+
(build-dispatch-call pvars exp y r mod)
+
(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))))))))))))
+
+ (define (gen-syntax-case x keys clauses r mod)
+ (if (null? clauses)
+ (build-primcall no-source 'syntax-violation
+ (list (build-data no-source #f)
+ (build-data no-source
+ "source expression failed to
match any pattern")
+ x))
+ (syntax-case (car clauses) ()
+ ((pat exp)
+ (if (and (id? #'pat)
+ (and-map (lambda (x) (not (free-id=? #'pat x)))
+ (cons #'(... ...) keys)))
+ (if (free-id=? #'pat #'_)
+ (expand #'exp r empty-wrap mod)
+ (let ((labels (list (gen-label)))
+ (var (gen-var #'pat)))
+ (build-call no-source
+ (build-simple-lambda
+ no-source (list (syntax->datum #'pat))
#f (list var)
+ '()
+ (expand #'exp
+ (extend-env labels
+ (list (make-binding
'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap #'(pat)
+ labels
empty-wrap)
+ mod))
+ (list x))))
+ (gen-clause x keys (cdr clauses) r
+ #'pat #t #'exp mod)))
+ ((pat fender exp)
+ (gen-clause x keys (cdr clauses) r
+ #'pat #'fender #'exp mod))
+ (_ (syntax-violation 'syntax-case "invalid clause"
+ (car clauses))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ val (key ...) m ...)
+ (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod))))
+ #'(key ...))
+ (let ((x (gen-var 'tmp)))
+ ;; fat finger binding and references to temp variable x
+ (build-call s
+ (build-simple-lambda no-source (list 'tmp) #f
(list x) '()
+ (gen-syntax-case
(build-lexical-reference no-source 'tmp x)
+ #'(key
...) #'(m ...)
+ r
+ mod))
+ (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
- (let ()
- (define (convert-pattern pattern keys ellipsis?)
- ;; accepts pattern & keys
- ;; returns $sc-dispatch pattern & ids
- (define cvt*
- (lambda (p* n ids)
- (syntax-case p* ()
- ((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))))))
- (_ (cvt p* n ids)))))
-
- (define (v-reverse x)
- (let loop ((r '()) (x x))
- (if (not (pair? x))
- (values r x)
- (loop (cons (car x) r) (cdr x)))))
-
- (define cvt
- (lambda (p n ids)
- (if (id? p)
- (cond
- ((bound-id-member? p keys)
- (values (vector 'free-id p) ids))
- ((free-id=? p #'_)
- (values '_ ids))
- (else
- (values 'any (cons (cons p n) ids))))
- (syntax-case p ()
- ((x dots)
- (ellipsis? (syntax dots))
- (call-with-values
- (lambda () (cvt (syntax x) (1+ n) ids))
- (lambda (p ids)
- (values (if (eq? p 'any) 'each-any (vector
'each p))
- ids))))
- ((x dots . ys)
- (ellipsis? (syntax dots))
- (call-with-values
- (lambda () (cvt* (syntax ys) n ids))
- (lambda (ys ids)
- (call-with-values
- (lambda () (cvt (syntax x) (+ n 1)
ids))
- (lambda (x ids)
- (call-with-values
- (lambda () (v-reverse ys))
- (lambda (ys e)
- (values `#(each+ ,x ,ys ,e)
- ids))))))))
- ((x . y)
- (call-with-values
- (lambda () (cvt (syntax y) n ids))
- (lambda (y ids)
- (call-with-values
- (lambda () (cvt (syntax x) n ids))
- (lambda (x ids)
- (values (cons x y) ids))))))
- (() (values '() ids))
- (#(x ...)
- (call-with-values
- (lambda () (cvt (syntax (x ...)) n ids))
- (lambda (p ids) (values (vector 'vector p)
ids))))
- (x (values (vector 'atom (strip p)) ids))))))
- (cvt pattern 0 '()))
-
- (define (build-dispatch-call 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
- no-source
- 'apply
- (list (build-simple-lambda no-source (map
syntax->datum ids) #f new-vars '()
- (expand exp
- (extend-env
- labels
- (map (lambda
(var level)
-
(make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr
pvars))
- r)
-
(make-binding-wrap ids labels empty-wrap)
- mod))
- y)))))
-
- (define (gen-clause 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)))
- ;; fat finger binding and references to temp
variable y
- (build-call no-source
- (build-simple-lambda no-source (list
'tmp) #f (list y) '()
- (let ((y
(build-lexical-reference no-source 'tmp y)))
-
(build-conditional no-source
-
(syntax-case fender ()
-
(#t y)
-
(_ (build-conditional no-source
-
y
-
(build-dispatch-call pvars fender y r mod)
-
(build-data no-source #f))))
-
(build-dispatch-call pvars exp y r mod)
-
(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))))))))))))
-
- (define (gen-syntax-case x keys clauses r mod)
- (if (null? clauses)
- (build-primcall no-source 'syntax-violation
- (list (build-data no-source #f)
- (build-data no-source
- "source expression
failed to match any pattern")
- x))
- (syntax-case (car clauses) ()
- ((pat exp)
- (if (and (id? #'pat)
- (and-map (lambda (x) (not (free-id=?
#'pat x)))
- (cons #'(... ...) keys)))
- (if (free-id=? #'pat #'_)
- (expand #'exp r empty-wrap mod)
- (let ((labels (list (gen-label)))
- (var (gen-var #'pat)))
- (build-call no-source
- (build-simple-lambda
- no-source (list
(syntax->datum #'pat)) #f (list var)
- '()
- (expand #'exp
- (extend-env labels
- (list
(make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap
#'(pat)
-
labels empty-wrap)
- mod))
- (list x))))
- (gen-clause x keys (cdr clauses) r
- #'pat #t #'exp mod)))
- ((pat fender exp)
- (gen-clause x keys (cdr clauses) r
- #'pat #'fender #'exp mod))
- (_ (syntax-violation 'syntax-case "invalid clause"
- (car clauses))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ val (key ...) m ...)
- (if (and-map (lambda (x) (and (id? x) (not
(ellipsis? x r mod))))
- #'(key ...))
- (let ((x (gen-var 'tmp)))
- ;; fat finger binding and references to temp
variable x
- (build-call s
- (build-simple-lambda no-source
(list 'tmp) #f (list x) '()
-
(gen-syntax-case (build-lexical-reference no-source 'tmp x)
-
#'(key ...) #'(m ...)
-
r
-
mod))
- (list (expand #'val r empty-wrap
mod))))
- (syntax-violation 'syntax-case "invalid literals
list" e))))))))
+ (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
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] branch main updated: psyntax: Separate core expanders from their installation,
Andy Wingo <=