[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 12/12: psyntax: Use new `match' instead of cdadring
From: |
Andy Wingo |
Subject: |
[Guile-commits] 12/12: psyntax: Use new `match' instead of cdadring |
Date: |
Fri, 15 Nov 2024 10:25:33 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit 2daea40200606a5e2dc14e643e439e891fbd6c5b
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Nov 15 15:35:10 2024 +0100
psyntax: Use new `match' instead of cdadring
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/psyntax.scm: Use `match' more. Also use more first-order
definitions. NFC.
---
module/ice-9/psyntax-pp.scm | 368 +++++++++++++++++++++++++++-----------------
module/ice-9/psyntax.scm | 102 ++++++------
2 files changed, 280 insertions(+), 190 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 2f8dcbe3d..efb2ae5c4 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -193,24 +193,75 @@
(let ((props (source-properties datum)))
(and (pair? props) (vector (assq-ref props 'filename)
(assq-ref props 'line) (assq-ref props 'column))))))
(source-annotation (lambda (x) (if (syntax? x) (syntax-sourcev x)
(datum-sourcev x))))
+ (binding-type (lambda (x) (car x)))
+ (binding-value (lambda (x) (cdr x)))
+ (null-env '())
(extend-env
(lambda (labels bindings r)
- (if (null? labels)
- r
- (extend-env (cdr labels) (cdr bindings) (cons (cons (car
labels) (car bindings)) r)))))
+ (let* ((v labels)
+ (fk (lambda ()
+ (let ((fk (lambda () (error "value failed to
match" v))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (let* ((label vx)
+ (labels vy)
+ (v bindings)
+ (fk (lambda () (error "value failed
to match" v))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (let* ((binding vx) (bindings vy))
+ (extend-env labels bindings
(acons label binding r))))
+ (fk))))
+ (fk))))))
+ (if (null? v) r (fk)))))
(extend-var-env
(lambda (labels vars r)
- (if (null? labels)
- r
- (extend-var-env (cdr labels) (cdr vars) (cons (cons (car
labels) (cons 'lexical (car vars))) r)))))
+ (let* ((v labels)
+ (fk (lambda ()
+ (let ((fk (lambda () (error "value failed to
match" v))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (let* ((label vx)
+ (labels vy)
+ (v vars)
+ (fk (lambda () (error "value failed
to match" v))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (let* ((var vx) (vars vy))
+ (extend-var-env labels vars
(acons label (cons 'lexical var) r))))
+ (fk))))
+ (fk))))))
+ (if (null? v) r (fk)))))
(macros-only-env
(lambda (r)
- (if (null? r)
- '()
- (let ((a (car r)))
- (if (memq (cadr a) '(macro syntax-parameter ellipsis))
- (cons a (macros-only-env (cdr r)))
- (macros-only-env (cdr r)))))))
+ (let* ((v r)
+ (fk (lambda ()
+ (let ((fk (lambda () (error "value failed to
match" v))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (let* ((a vx)
+ (r vy)
+ (v a)
+ (fk (lambda ()
+ (let ((fk (lambda () (error
"value failed to match" v))))
+ (macros-only-env r)))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (let ((k vx))
+ (if (pair? vy)
+ (let ((vx (car vy)) (vy (cdr
vy)))
+ (let ((tk (lambda () (cons
a (macros-only-env r)))))
+ (if (eq? vx 'macro)
+ (tk)
+ (let ((tk (lambda ()
(tk))))
+ (if (eq? vx
'syntax-parameter)
+ (tk)
+ (let ((tk
(lambda () (tk))))
+ (if (eq? vx
'ellipsis) (tk) (fk))))))))
+ (fk))))
+ (fk))))
+ (fk))))))
+ (if (null? v) '() (fk)))))
(global-extend
(lambda (type sym val) (module-define! (current-module) sym
(make-syntax-transformer sym type val))))
(nonsymbol-id? (lambda (x) (and (syntax? x) (symbol?
(syntax-expression x)))))
@@ -218,15 +269,26 @@
(id-sym-name&marks
(lambda (x w)
(if (syntax? x)
- (values (syntax-expression x) (join-marks (car w) (car
(syntax-wrap x))))
- (values x (car w)))))
+ (values (syntax-expression x) (join-marks (wrap-marks w)
(wrap-marks (syntax-wrap x))))
+ (values x (wrap-marks w)))))
+ (make-wrap (lambda (marks subst) (cons marks subst)))
+ (wrap-marks (lambda (wrap) (car wrap)))
+ (wrap-subst (lambda (wrap) (cdr wrap)))
(gen-unique
(lambda* (#:optional (module (current-module)))
(if module
(vector (module-name module) (module-generate-unique-id!
module))
(vector '(guile) (gensym "id")))))
(gen-label (lambda () (gen-unique)))
- (gen-labels (lambda (ls) (if (null? ls) '() (cons (gen-label)
(gen-labels (cdr ls))))))
+ (gen-labels
+ (lambda (ls)
+ (let* ((v ls)
+ (fk (lambda ()
+ (let ((fk (lambda () (error "value failed to
match" v))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v))) (let ((ls
vy)) (cons (gen-label) (gen-labels ls))))
+ (fk))))))
+ (if (null? v) '() (fk)))))
(make-ribcage (lambda (symnames marks labels) (vector 'ribcage
symnames marks labels)))
(ribcage-symnames (lambda (ribcage) (vector-ref ribcage 1)))
(ribcage-marks (lambda (ribcage) (vector-ref ribcage 2)))
@@ -234,37 +296,54 @@
(set-ribcage-symnames! (lambda (ribcage x) (vector-set! ribcage 1
x)))
(set-ribcage-marks! (lambda (ribcage x) (vector-set! ribcage 2 x)))
(set-ribcage-labels! (lambda (ribcage x) (vector-set! ribcage 3
x)))
- (anti-mark (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr
w)))))
+ (empty-wrap '(()))
+ (top-wrap '((top)))
+ (the-anti-mark #f)
+ (anti-mark (lambda (w) (make-wrap (cons the-anti-mark (wrap-marks
w)) (cons 'shift (wrap-subst w)))))
(new-mark (lambda () (gen-unique)))
(extend-ribcage!
(lambda (ribcage id label)
(set-ribcage-symnames! ribcage (cons (syntax-expression id)
(ribcage-symnames ribcage)))
- (set-ribcage-marks! ribcage (cons (car (syntax-wrap id))
(ribcage-marks ribcage)))
+ (set-ribcage-marks! ribcage (cons (wrap-marks (syntax-wrap id))
(ribcage-marks ribcage)))
(set-ribcage-labels! ribcage (cons label (ribcage-labels
ribcage)))))
(make-binding-wrap
(lambda (ids labels w)
- (if (null? ids)
- w
- (cons (car w)
- (cons (let* ((labelvec (list->vector labels)) (n
(vector-length labelvec)))
- (let ((symnamevec (make-vector n)) (marksvec
(make-vector n)))
- (let f ((ids ids) (i 0))
- (if (not (null? ids))
- (call-with-values
- (lambda () (id-sym-name&marks (car
ids) w))
- (lambda (symname marks)
- (vector-set! symnamevec i symname)
- (vector-set! marksvec i marks)
- (f (cdr ids) (#{1+}# i))))))
- (make-ribcage symnamevec marksvec
labelvec)))
- (cdr w))))))
+ (let* ((v ids)
+ (fk (lambda ()
+ (let ((fk (lambda () (error "value failed to
match" v))))
+ (if (pair? v)
+ (let ((vx (car v)) (vy (cdr v)))
+ (make-wrap
+ (wrap-marks w)
+ (cons (let* ((labelvec (list->vector
labels))
+ (n (vector-length labelvec))
+ (symnamevec (make-vector n))
+ (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (let* ((v ids)
+ (fk (lambda ()
+ (let ((fk (lambda
() (error "value failed to match" v))))
+ (if (pair? v)
+ (let ((vx
(car v)) (vy (cdr v)))
+ (let* ((id
vx) (ids vy))
+
(call-with-values
+ (lambda
() (id-sym-name&marks id w))
+ (lambda
(symname marks)
+
(vector-set! symnamevec i symname)
+
(vector-set! marksvec i marks)
+ (f
ids (#{1+}# i))))))
+ (fk))))))
+ (if (null? v) (make-ribcage
symnamevec marksvec labelvec) (fk)))))
+ (wrap-subst w))))
+ (fk))))))
+ (if (null? v) w (fk)))))
(smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
(join-wraps
(lambda (w1 w2)
- (let ((m1 (car w1)) (s1 (cdr w1)))
+ (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
(if (null? m1)
- (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr
w2))))
- (cons (smart-append m1 (car w2)) (smart-append s1 (cdr
w2)))))))
+ (if (null? s1) w2 (make-wrap (wrap-marks w2)
(smart-append s1 (wrap-subst w2))))
+ (make-wrap (smart-append m1 (wrap-marks w2))
(smart-append s1 (wrap-subst w2)))))))
(join-marks (lambda (m1 m2) (smart-append m1 m2)))
(same-marks?
(lambda (x y)
@@ -311,13 +390,13 @@
(values n marks))))
(else (f (#{1+}# i)))))))))
(cond
- ((symbol? id) (or (search id (cdr w) (car w) mod) id))
+ ((symbol? id) (or (search id (wrap-subst w) (wrap-marks w)
mod) id))
((syntax? id)
(let ((id (syntax-expression id)) (w1 (syntax-wrap id))
(mod (or (syntax-module id) mod)))
- (let ((marks (join-marks (car w) (car w1))))
+ (let ((marks (join-marks (wrap-marks w) (wrap-marks
w1))))
(call-with-values
- (lambda () (search id (cdr w) marks mod))
- (lambda (new-id marks) (or new-id (search id (cdr w1)
marks mod) id))))))
+ (lambda () (search id (wrap-subst w) marks mod))
+ (lambda (new-id marks) (or new-id (search id
(wrap-subst w1) marks mod) id))))))
(else (syntax-violation 'id-var-name "invalid id" id))))))
(locally-bound-identifiers
(lambda (w mod)
@@ -338,7 +417,7 @@
(scan (cdr subst) results)
(f (cdr symnames)
(cdr marks)
- (cons (wrap (car symnames) (anti-mark
(cons (car marks) subst)) mod) results))))))
+ (cons (wrap (car symnames) (anti-mark
(make-wrap (car marks) subst)) mod) results))))))
(scan-vector-rib
(lambda (subst symnames marks results)
(let ((n (vector-length symnames)))
@@ -347,10 +426,10 @@
(scan (cdr subst) results)
(f (#{1+}# i)
(cons (wrap (vector-ref symnames i)
- (anti-mark (cons
(vector-ref marks i) subst))
+ (anti-mark (make-wrap
(vector-ref marks i) subst))
mod)
results))))))))
- (scan (cdr w) '()))))
+ (scan (wrap-subst w) '()))))
(resolve-identifier
(lambda (id w r mod resolve-syntax-parameters?)
(letrec* ((resolve-global
@@ -367,7 +446,7 @@
(if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters?
(let ((lexical (assq-ref r v)))
- (values 'macro (if lexical (cdr
lexical) trans) mod))
+ (values 'macro (if lexical
(binding-value lexical) trans) mod))
(values type v mod))
(values type trans mod)))
(values 'global var mod)))))
@@ -375,7 +454,7 @@
(lambda (label mod)
(let ((b (assq-ref r label)))
(if b
- (let ((type (car b)) (value (cdr b)))
+ (let ((type (binding-type b)) (value
(binding-value b)))
(if (eq? type 'syntax-parameter)
(if resolve-syntax-parameters?
(values 'macro value mod)
@@ -402,8 +481,8 @@
(lambda (i j)
(let* ((mi (and (syntax? i) (syntax-module i)))
(mj (and (syntax? j) (syntax-module j)))
- (ni (id-var-name i '(()) mi))
- (nj (id-var-name j '(()) mj)))
+ (ni (id-var-name i empty-wrap mi))
+ (nj (id-var-name j empty-wrap mj)))
(letrec* ((id-module-binding
(lambda (id mod)
(module-variable
@@ -422,7 +501,7 @@
(lambda (i j)
(if (and (syntax? i) (syntax? j))
(and (eq? (syntax-expression i) (syntax-expression j))
- (same-marks? (car (syntax-wrap i)) (car (syntax-wrap
j))))
+ (same-marks? (wrap-marks (syntax-wrap i)) (wrap-marks
(syntax-wrap j))))
(eq? i j))))
(valid-bound-ids?
(lambda (ids)
@@ -441,7 +520,7 @@
(source-wrap
(lambda (x w s defmod)
(cond
- ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x)
+ ((and (null? (wrap-marks w)) (null? (wrap-subst w)) (not
defmod) (not s)) x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))
defmod))
((null? x) x)
(else (make-syntax x w defmod s)))))
@@ -457,12 +536,13 @@
(lambda (body r w s m esew mod)
(let* ((r (cons '("placeholder" placeholder) r))
(ribcage (make-ribcage '() '() '()))
- (w (cons (car w) (cons ribcage (cdr w)))))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst
w)))))
(letrec* ((record-definition!
(lambda (id var)
(let ((mod (cons 'hygiene (module-name
(current-module)))))
- (extend-ribcage! ribcage id (cons (or
(syntax-module id) mod) (wrap var '((top)) mod))))))
- (macro-introduced-identifier? (lambda (id) (not
(equal? (car (syntax-wrap id)) '(top)))))
+ (extend-ribcage! ribcage id (cons (or
(syntax-module id) mod) (wrap var top-wrap mod))))))
+ (macro-introduced-identifier?
+ (lambda (id) (not (equal? (wrap-marks (syntax-wrap
id)) '(top)))))
(ensure-fresh-name
(lambda (var)
(letrec* ((ribcage-has-var?
@@ -515,7 +595,7 @@
(top-level-eval x mod)
(lambda () x))
(call-with-values
- (lambda ()
(resolve-identifier id '(()) r mod #t))
+ (lambda ()
(resolve-identifier id empty-wrap r mod #t))
(lambda (type* value*
mod*)
(if (eq? type* 'macro)
(top-level-eval
@@ -646,7 +726,7 @@
((memv key '(macro))
(if for-car?
(values type value e e w s mod)
- (syntax-type (expand-macro value e r w s rib
mod) r '(()) s rib mod #f)))
+ (syntax-type (expand-macro value e r w s rib
mod) r empty-wrap s rib mod #f)))
((memv key '(global)) (values type value e value w s
mod*))
(else (values type value e e w s mod)))))))
((pair? e)
@@ -662,7 +742,7 @@
(values 'primitive-call fval e e w s mod)
(values 'global-call (make-syntax fval w fmod
fs) e e w s mod)))
((memv key '(macro))
- (syntax-type (expand-macro fval e r w s rib mod) r
'(()) s rib mod for-car?))
+ (syntax-type (expand-macro fval e r w s rib mod) r
empty-wrap s rib mod for-car?))
((memv key '(module-ref))
(call-with-values
(lambda () (fval e r w mod))
@@ -688,10 +768,10 @@
(source-wrap
(cons (make-syntax 'lambda
'((top)) '(hygiene guile))
(wrap (cons args
(cons e1 e2)) w mod))
- '(())
+ empty-wrap
s
#f)
- '(())
+ empty-wrap
s
mod))
tmp-1)
@@ -703,7 +783,7 @@
(wrap name w mod)
(wrap e w mod)
(list (make-syntax 'if
'((top)) '(hygiene guile)) #f #f)
- '(())
+ empty-wrap
s
mod))
tmp-1)
@@ -813,7 +893,7 @@
(syntax-violation #f "source expression failed to match
any pattern" tmp-1)))))
(expand-macro
(lambda (p e r w s rib mod)
- (letrec* ((decorate-source (lambda (x) (source-wrap x '(()) s
#f)))
+ (letrec* ((decorate-source (lambda (x) (source-wrap x
empty-wrap s #f)))
(map* (lambda (f x)
(cond ((null? x) x) ((pair? x) (cons (f (car
x)) (map* f (cdr x)))) (else (f x)))))
(rebuild-macro-output
@@ -822,12 +902,12 @@
((pair? x) (decorate-source (map* (lambda (x)
(rebuild-macro-output x m)) x)))
((syntax? x)
(let ((w (syntax-wrap x)))
- (let ((ms (car w)) (ss (cdr w)))
- (if (and (pair? ms) (eq? (car ms) #f))
- (wrap-syntax x (cons (cdr ms) (if rib
(cons rib (cdr ss)) (cdr ss))) mod)
+ (let ((ms (wrap-marks w)) (ss (wrap-subst w)))
+ (if (and (pair? ms) (eq? (car ms)
the-anti-mark))
+ (wrap-syntax x (make-wrap (cdr ms) (if
rib (cons rib (cdr ss)) (cdr ss))) mod)
(wrap-syntax
x
- (cons (cons m ms) (if rib (cons rib
(cons 'shift ss)) (cons 'shift ss)))
+ (make-wrap (cons m ms) (if rib (cons
rib (cons 'shift ss)) (cons 'shift ss)))
mod)))))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector
n)))
@@ -842,20 +922,20 @@
(syntax-violation
#f
"encountered raw symbol in macro output"
- (source-wrap e w (cdr w) mod)
+ (source-wrap e w (wrap-subst w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-f01 transformer-environment)
- (t-680b775fb37a463-f02 (lambda (k) (k e r w s rib
mod))))
+ (let* ((t-680b775fb37a463-f33 transformer-environment)
+ (t-680b775fb37a463-f34 (lambda (k) (k e r w s rib
mod))))
(with-fluid*
- t-680b775fb37a463-f01
- t-680b775fb37a463-f02
+ t-680b775fb37a463-f33
+ t-680b775fb37a463-f34
(lambda () (rebuild-macro-output (p (source-wrap e
(anti-mark w) s mod)) (new-mark))))))))
(expand-body
(lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r))
(ribcage (make-ribcage '() '() '()))
- (w (cons (car w) (cons ribcage (cdr w)))))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst
w)))))
(let parse ((body (map (lambda (x) (cons r (wrap x w mod)))
body))
(ids '())
(labels '())
@@ -890,7 +970,7 @@
(parse body ids labels (cons #f var-ids) (cons #f vars)
(cons expand-tail-expr vals) bindings #f))
(else (let ((e (cdar body)) (er (caar body)) (body (cdr
body)))
(call-with-values
- (lambda () (syntax-type e er '(())
(source-annotation e) ribcage mod #f))
+ (lambda () (syntax-type e er empty-wrap
(source-annotation e) ribcage mod #f))
(lambda (type value form e w s mod)
(let ((key type))
(cond
@@ -904,7 +984,7 @@
(cons id var-ids)
(cons var vars)
(cons (let ((wrapped
(source-wrap e w s mod)))
- (lambda () (expand
wrapped er '(()) mod)))
+ (lambda () (expand
wrapped er empty-wrap mod)))
vals)
(cons (cons 'lexical var)
bindings)
#f))))
@@ -975,7 +1055,7 @@
vars
vals
bindings
- (lambda () (expand wrapped
er '(()) mod))))))))))))))))
+ (lambda () (expand wrapped
er empty-wrap mod))))))))))))))))
(expand-local-syntax
(lambda (rec? e r w s mod k)
(let* ((tmp e) (tmp ($sc-dispatch tmp '(_ #(each (any any)) any
. each-any))))
@@ -1010,7 +1090,7 @@
(lambda ()
(resolve-identifier
(make-syntax '#{ $sc-ellipsis }# (syntax-wrap e) (or
(syntax-module e) mod) #f)
- '(())
+ empty-wrap
r
mod
#f))
@@ -1379,11 +1459,11 @@
s
mod
get-formals
- (map (lambda
(tmp-680b775fb37a463-117d
-
tmp-680b775fb37a463-117c
-
tmp-680b775fb37a463-117b)
- (cons
tmp-680b775fb37a463-117b
- (cons
tmp-680b775fb37a463-117c tmp-680b775fb37a463-117d)))
+ (map (lambda
(tmp-680b775fb37a463-11a1
+
tmp-680b775fb37a463-11a0
+
tmp-680b775fb37a463-119f)
+ (cons
tmp-680b775fb37a463-119f
+ (cons
tmp-680b775fb37a463-11a0 tmp-680b775fb37a463-11a1)))
e2*
e1*
args*)))
@@ -1408,7 +1488,7 @@
(gen-var (lambda (id) (let ((id (if (syntax? id)
(syntax-expression id) id))) (gen-lexical id))))
(lambda-var-list
(lambda (vars)
- (let lvl ((vars vars) (ls '()) (w '(())))
+ (let lvl ((vars vars) (ls '()) (w empty-wrap))
(cond
((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f)
ls) w))
((id? vars) (cons (wrap vars w #f) ls))
@@ -1472,7 +1552,7 @@
(lambda (src e r maps ellipsis? mod)
(if (id? e)
(call-with-values
- (lambda () (resolve-identifier e '(()) r mod #f))
+ (lambda () (resolve-identifier e empty-wrap r mod #f))
(lambda (type value mod)
(let ((key type))
(cond
@@ -1651,8 +1731,8 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ (map (lambda (tmp-680b775fb37a463-6be
tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6bc)
+ (cons tmp-680b775fb37a463-6bc (cons
tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6be)))
e2
e1
args)))
@@ -1662,9 +1742,9 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-74d
tmp-680b775fb37a463-74c tmp-680b775fb37a463-74b)
- (cons tmp-680b775fb37a463-74b
- (cons tmp-680b775fb37a463-74c
tmp-680b775fb37a463-74d)))
+ (map (lambda (tmp-680b775fb37a463-6d4
tmp-680b775fb37a463-6d3 tmp-680b775fb37a463-6d2)
+ (cons tmp-680b775fb37a463-6d2
+ (cons tmp-680b775fb37a463-6d3
tmp-680b775fb37a463-6d4)))
e2
e1
args)))
@@ -1684,8 +1764,8 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-6ff)
- (cons tmp-680b775fb37a463-6ff (cons
tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
+ (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2
e1
args)))
@@ -1695,8 +1775,9 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ (map (lambda (tmp-680b775fb37a463-69e
tmp-680b775fb37a463-69d tmp-680b775fb37a463-69c)
+ (cons tmp-680b775fb37a463-69c
+ (cons tmp-680b775fb37a463-69d
tmp-680b775fb37a463-69e)))
e2
e1
args)))
@@ -1807,7 +1888,7 @@
((memv key '(global)) (build-global-assignment s
value (expand val r w mod) id-mod))
((memv key '(macro))
(if (procedure-property value
'variable-transformer)
- (expand (expand-macro value e r w s #f mod)
r '(()) mod)
+ (expand (expand-macro value e r w s #f mod)
r empty-wrap mod)
(syntax-violation
'set!
"not a variable transformer"
@@ -1821,7 +1902,7 @@
(if tmp
(apply (lambda (head tail val)
(call-with-values
- (lambda () (syntax-type head r '(()) #f #f mod
#t))
+ (lambda () (syntax-type head r empty-wrap #f #f
mod #t))
(lambda (type value ee* ee ww ss modmod)
(let ((key type))
(if (memv key '(module-ref))
@@ -1854,7 +1935,7 @@
(values
(syntax->datum id)
r
- '((top))
+ top-wrap
#f
(syntax->datum (cons (make-syntax 'public '((top))
'(hygiene guile)) mod))))
tmp)
@@ -1884,14 +1965,14 @@
(apply (lambda (id)
(and (id? id) (equal? (cdr (or (and (syntax? id)
(syntax-module id)) mod)) '(guile))))
tmp-1))
- (apply (lambda (id) (values (syntax->datum id) r '((top)) #f
'(primitive))) tmp-1)
+ (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))
+ top-wrap
#f
(syntax->datum (cons (make-syntax 'private
'((top)) '(hygiene guile)) mod))))
tmp-1)
@@ -2019,7 +2100,7 @@
labels
(map (lambda (var level) (cons 'syntax (cons
var level))) new-vars (map cdr pvars))
r)
- (make-binding-wrap ids labels '(()))
+ (make-binding-wrap ids labels empty-wrap)
mod))
y))))))
(gen-clause
@@ -2072,7 +2153,7 @@
(lambda (x) (not (free-id=? pat
x)))
(cons (make-syntax '...
'((top)) '(hygiene guile)) keys)))
(if (free-id=? pat (make-syntax '_
'((top)) '(hygiene guile)))
- (expand exp r '(()) mod)
+ (expand exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var pat)))
(build-call
#f
@@ -2085,7 +2166,7 @@
(expand
exp
(extend-env labels (list
(cons 'syntax (cons var 0))) r)
- (make-binding-wrap (list
pat) labels '(()))
+ (make-binding-wrap (list
pat) labels empty-wrap)
mod))
(list x))))
(gen-clause x keys (cdr clauses) r
pat #t exp mod)))
@@ -2111,7 +2192,7 @@
(list x)
'()
(gen-syntax-case (build-lexical-reference
'value #f 'tmp x) key m r mod))
- (list (expand val 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))))))
@@ -2132,8 +2213,8 @@
(else (annotate x)))))))
(expand-top-sequence
(list (unstrip x))
- '()
- '((top))
+ null-env
+ top-wrap
#f
m
esew
@@ -2147,7 +2228,7 @@
(vector (assq-ref alist 'filename) (assq-ref
alist 'line) (assq-ref alist 'column))))))
(make-syntax
datum
- (if id (syntax-wrap id) '(()))
+ (if id (syntax-wrap id) empty-wrap)
(and id (syntax-module id))
(cond
((not source) (props->sourcev (source-properties datum)))
@@ -2159,7 +2240,7 @@
(lambda (ls)
(let ((x ls)) (if (not (list? x)) (syntax-violation
'generate-temporaries "invalid argument" x)))
(let ((mod (cons 'hygiene (module-name (current-module)))))
- (map (lambda (x) (wrap (gen-var 't) '((top)) mod)) ls))))
+ (map (lambda (x) (wrap (gen-var 't) top-wrap mod)) ls))))
(set! free-identifier=?
(lambda (x y)
(let ((x x)) (if (not (nonsymbol-id? x)) (syntax-violation
'free-identifier=? "invalid argument" x)))
@@ -2194,10 +2275,10 @@
(lambda (e r w s rib mod)
(letrec* ((strip-anti-mark
(lambda (w)
- (let ((ms (car w)) (s (cdr w)))
- (if (and (pair? ms) (eq? (car ms) #f))
- (cons (cdr ms) (if rib (cons rib (cdr
s)) (cdr s)))
- (cons ms (if rib (cons rib s) s)))))))
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (if (and (pair? ms) (eq? (car ms)
the-anti-mark))
+ (make-wrap (cdr ms) (if rib (cons rib
(cdr s)) (cdr s)))
+ (make-wrap ms (if rib (cons rib s)
s)))))))
(call-with-values
(lambda ()
(resolve-identifier
@@ -2318,7 +2399,7 @@
((eq? p 'any) (list e))
((eq? p '_) '())
((syntax? e) (match* (syntax-expression e) p (syntax-wrap e)
'() (syntax-module e)))
- (else (match* e p '(()) '() #f))))))))
+ (else (match* e p empty-wrap '() #f))))))))
(define with-syntax
(let ((make-syntax make-syntax))
@@ -2477,8 +2558,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
+ (map (lambda (tmp-680b775fb37a463-12bc
tmp-680b775fb37a463-12bb tmp-680b775fb37a463-12ba)
+ (list (cons tmp-680b775fb37a463-12ba
tmp-680b775fb37a463-12bb)
+ tmp-680b775fb37a463-12bc))
template
pattern
keyword)))
@@ -2493,11 +2575,11 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-12b2
- tmp-680b775fb37a463-12b1
- tmp-680b775fb37a463-12b0)
- (list (cons tmp-680b775fb37a463-12b0
tmp-680b775fb37a463-12b1)
- tmp-680b775fb37a463-12b2))
+ (map (lambda (tmp-680b775fb37a463-12d5
+ tmp-680b775fb37a463-12d4
+ tmp-680b775fb37a463-12d3)
+ (list (cons tmp-680b775fb37a463-12d3
tmp-680b775fb37a463-12d4)
+ tmp-680b775fb37a463-12d5))
template
pattern
keyword)))
@@ -2509,11 +2591,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-12cb
- tmp-680b775fb37a463-12ca
- tmp-680b775fb37a463-12c9)
- (list (cons
tmp-680b775fb37a463-12c9 tmp-680b775fb37a463-12ca)
- tmp-680b775fb37a463-12cb))
+ (map (lambda (tmp-680b775fb37a463-12ee
+ tmp-680b775fb37a463-12ed
+ tmp-680b775fb37a463-12ec)
+ (list (cons
tmp-680b775fb37a463-12ec tmp-680b775fb37a463-12ed)
+ tmp-680b775fb37a463-12ee))
template
pattern
keyword)))
@@ -2529,11 +2611,11 @@
dots
k
(list docstring)
- (map (lambda
(tmp-680b775fb37a463-12ea
-
tmp-680b775fb37a463-12e9
-
tmp-680b775fb37a463-12e8)
- (list (cons
tmp-680b775fb37a463-12e8 tmp-680b775fb37a463-12e9)
-
tmp-680b775fb37a463-12ea))
+ (map (lambda
(tmp-680b775fb37a463-130d
+
tmp-680b775fb37a463-130c
+
tmp-680b775fb37a463-130b)
+ (list (cons
tmp-680b775fb37a463-130b tmp-680b775fb37a463-130c)
+
tmp-680b775fb37a463-130d))
template
pattern
keyword)))
@@ -2661,8 +2743,9 @@
(apply (lambda (p)
(if (=
lev 0)
(quasilist*
-
(map (lambda (tmp-680b775fb37a463)
-
(list "value" tmp-680b775fb37a463))
+
(map (lambda (tmp-680b775fb37a463-13ba)
+
(list "value"
+
tmp-680b775fb37a463-13ba))
p)
(quasi q lev))
(quasicons
@@ -2688,9 +2771,9 @@
(apply
(lambda (p)
(if (= lev 0)
(quasiappend
-
(map (lambda (tmp-680b775fb37a463-139c)
+
(map (lambda (tmp-680b775fb37a463-13bf)
(list "value"
-
tmp-680b775fb37a463-139c))
+
tmp-680b775fb37a463-13bf))
p)
(quasi q lev))
(quasicons
@@ -2726,8 +2809,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-13b2)
- (list "value"
tmp-680b775fb37a463-13b2))
+ (map (lambda
(tmp-680b775fb37a463-13d5)
+ (list "value"
tmp-680b775fb37a463-13d5))
p)
(vquasi q lev))
(quasicons
@@ -2747,8 +2830,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-13b7)
- (list
"value" tmp-680b775fb37a463-13b7))
+ (map (lambda
(tmp-680b775fb37a463-13da)
+ (list
"value" tmp-680b775fb37a463-13da))
p)
(vquasi q lev))
(quasicons
@@ -2840,8 +2923,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda
(tmp-680b775fb37a463-140c)
- (list "quote"
tmp-680b775fb37a463-140c))
+ (k (map (lambda
(tmp-680b775fb37a463-142f)
+ (list "quote"
tmp-680b775fb37a463-142f))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom
"list") . each-any))))
@@ -2852,8 +2935,8 @@
(apply (lambda (y z) (f z
(lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp))
(let ((tmp x))
- (let
((t-680b775fb37a463-141b tmp))
- (list "list->vector"
t-680b775fb37a463-141b)))))))))))))))))
+ (let
((t-680b775fb37a463-143e tmp))
+ (list "list->vector"
t-680b775fb37a463-143e)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
any))))
@@ -2865,9 +2948,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-142a)
+ (apply (lambda
(t-680b775fb37a463-144d)
(cons
(make-syntax 'list '((top)) '(hygiene guile))
-
t-680b775fb37a463-142a))
+
t-680b775fb37a463-144d))
tmp)
(syntax-violation
#f
@@ -2883,14 +2966,13 @@
(let ((tmp-1 (list
(emit (car x*)) (f (cdr x*)))))
(let ((tmp
($sc-dispatch tmp-1 '(any any))))
(if tmp
- (apply
(lambda (t-680b775fb37a463-143e
-
t-680b775fb37a463-143d)
+ (apply
(lambda (t-680b775fb37a463-1 t-680b775fb37a463)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
-
t-680b775fb37a463-143e
-
t-680b775fb37a463-143d))
+
t-680b775fb37a463-1
+
t-680b775fb37a463))
tmp)
(syntax-violation
#f
@@ -2903,12 +2985,12 @@
(let ((tmp-1 (map
emit x)))
(let ((tmp
($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply
(lambda (t-680b775fb37a463-144a)
+ (apply
(lambda (t-680b775fb37a463-146d)
(cons (make-syntax
'append
'((top))
'(hygiene guile))
-
t-680b775fb37a463-144a))
+
t-680b775fb37a463-146d))
tmp)
(syntax-violation
#f
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 4bf50103b..bb71dc585 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -411,36 +411,40 @@
((_ type value) (cons type value))
((_ 'type) '(type))
((_ type) (cons type '()))))
- (define-syntax-rule (binding-type x)
- (car x))
- (define-syntax-rule (binding-value x)
- (cdr x))
-
- (define-syntax null-env (identifier-syntax '()))
+ (define (binding-type x) (car x))
+ (define (binding-value x) (cdr x))
+ (define null-env '())
(define (extend-env labels bindings r)
- (if (null? labels)
- r
- (extend-env (cdr labels) (cdr bindings)
- (cons (cons (car labels) (car bindings)) r))))
+ (match labels
+ (() r)
+ ((label . labels)
+ (match bindings
+ ((binding . bindings)
+ (extend-env labels bindings (acons label binding r)))))))
(define (extend-var-env labels vars r)
;; variant of extend-env that forms "lexical" binding
- (if (null? labels)
- r
- (extend-var-env (cdr labels) (cdr vars)
- (cons (cons (car labels) (make-binding 'lexical (car
vars))) r))))
+ (match labels
+ (() r)
+ ((label . labels)
+ (match vars
+ ((var . vars)
+ (extend-var-env labels vars
+ (acons label (make-binding 'lexical var) r)))))))
;; we use a "macros only" environment in expansion of local macro
;; definitions so that their definitions can use local macros without
;; attempting to use other lexical identifiers.
(define (macros-only-env r)
- (if (null? r)
- '()
- (let ((a (car r)))
- (if (memq (cadr a) '(macro syntax-parameter ellipsis))
- (cons a (macros-only-env (cdr r)))
- (macros-only-env (cdr r))))))
+ (match r
+ (() '())
+ ((a . r)
+ (match a
+ ((k . ((or 'macro 'syntax-parameter 'ellipsis) . _))
+ (cons a (macros-only-env r)))
+ (_
+ (macros-only-env r))))))
(define (global-extend type sym val)
(module-define! (current-module)
@@ -483,9 +487,9 @@
;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
- (define-syntax make-wrap (identifier-syntax cons))
- (define-syntax wrap-marks (identifier-syntax car))
- (define-syntax wrap-subst (identifier-syntax cdr))
+ (define (make-wrap marks subst) (cons marks subst))
+ (define (wrap-marks wrap) (car wrap))
+ (define (wrap-subst wrap) (cdr wrap))
(define* (gen-unique #:optional (module (current-module)))
;; Generate a unique value, used as a mark to identify a scope, or
@@ -512,9 +516,9 @@
(gen-unique))
(define (gen-labels ls)
- (if (null? ls)
- '()
- (cons (gen-label) (gen-labels (cdr ls)))))
+ (match ls
+ (() '())
+ ((_ . ls) (cons (gen-label) (gen-labels ls)))))
(define (make-ribcage symnames marks labels)
(vector 'ribcage symnames marks labels))
@@ -525,14 +529,14 @@
(define (set-ribcage-marks! ribcage x) (vector-set! ribcage 2 x))
(define (set-ribcage-labels! ribcage x) (vector-set! ribcage 3 x))
- (define-syntax empty-wrap (identifier-syntax '(())))
- (define-syntax top-wrap (identifier-syntax '((top))))
+ (define empty-wrap '(()))
+ (define top-wrap '((top)))
;; Marks must be comparable with "eq?" and distinct from pairs and
;; the symbol top. We do not use integers so that marks will remain
;; unique even across file compiles.
- (define-syntax the-anti-mark (identifier-syntax #f))
+ (define the-anti-mark #f)
(define (anti-mark w)
(make-wrap (cons the-anti-mark (wrap-marks w))
@@ -559,24 +563,28 @@
;; make-binding-wrap creates vector-based ribcages
(define (make-binding-wrap ids labels w)
- (if (null? ids)
- w
- (make-wrap
- (wrap-marks w)
- (cons
- (let ((labelvec (list->vector labels)))
- (let ((n (vector-length labelvec)))
- (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
- (let f ((ids ids) (i 0))
- (if (not (null? ids))
- (call-with-values
- (lambda () (id-sym-name&marks (car ids) w))
- (lambda (symname marks)
- (vector-set! symnamevec i symname)
- (vector-set! marksvec i marks)
- (f (cdr ids) (1+ i))))))
- (make-ribcage symnamevec marksvec labelvec))))
- (wrap-subst w)))))
+ (match ids
+ (() w)
+ ((_ . _)
+ (make-wrap
+ (wrap-marks w)
+ (cons
+ (let* ((labelvec (list->vector labels))
+ (n (vector-length labelvec))
+ (symnamevec (make-vector n))
+ (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (match ids
+ (()
+ (make-ribcage symnamevec marksvec labelvec))
+ ((id . ids)
+ (call-with-values
+ (lambda () (id-sym-name&marks id w))
+ (lambda (symname marks)
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f ids (1+ i))))))))
+ (wrap-subst w))))))
(define (smart-append m1 m2)
(if (null? m2)
- [Guile-commits] branch main updated (bb7154fb8 -> 2daea4020), Andy Wingo, 2024/11/15
- [Guile-commits] 05/12: psyntax: Clean up use of fx+, etc, Andy Wingo, 2024/11/15
- [Guile-commits] 06/12: psyntax: Functional annotation of function names, Andy Wingo, 2024/11/15
- [Guile-commits] 10/12: psyntax: Add simple pattern matcher, Andy Wingo, 2024/11/15
- [Guile-commits] 04/12: psyntax: Rename top-level-eval, local-eval, Andy Wingo, 2024/11/15
- [Guile-commits] 07/12: psyntax: Inline the single use of define-structure, Andy Wingo, 2024/11/15
- [Guile-commits] 08/12: psyntax: Remove a useless level of let, Andy Wingo, 2024/11/15
- [Guile-commits] 12/12: psyntax: Use new `match' instead of cdadring,
Andy Wingo <=
- [Guile-commits] 11/12: psyntax: Use new `match' instead of cdadring, Andy Wingo, 2024/11/15
- [Guile-commits] 09/12: psyntax: Avoid lambda in procedure definitions, Andy Wingo, 2024/11/15
- [Guile-commits] 01/12: psyntax: Clean up lexical gensym creation, Andy Wingo, 2024/11/15
- [Guile-commits] 03/12: psyntax: Use vectors instead of gensyms for labels, marks, Andy Wingo, 2024/11/15
- [Guile-commits] 02/12: psyntax: Remove useless gen-label invocations, Andy Wingo, 2024/11/15