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

psyntax: Simplify locally-bound-identifiers

Browse source 
* module/ice-9/psyntax.scm (locally-bound-identifiers): Simplify to use
match and scope.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-18 10:21:41 +01:00
parent 54c8901adc
commit 12afcc74fb
2 changed files with 149 additions and 111 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -498,36 +498,80 @@
(else (syntax-violation 'id-var-name "invalid id" id)))))) (else (syntax-violation 'id-var-name "invalid id" id))))))
(locally-bound-identifiers (locally-bound-identifiers
(lambda (w mod) (lambda (w mod)
(letrec* ((scan (lambda (subst results) (let scan ((subst (wrap-subst w)) (results '()))
(if (null? subst) (let* ((v subst)
results (fk (lambda ()
(let ((fst (car subst))) (let ((fk (lambda ()
(if (eq? fst 'shift) (let ((fk (lambda () (error "value failed to match" v))))
(scan (cdr subst) results) (if (pair? v)
(let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst))) (let ((vx (car v)) (vy (cdr v)))
(if (vector? symnames) (if (and (vector? vx)
(scan-vector-rib subst symnames marks results) (eq? (vector-length vx)
(scan-list-rib subst symnames marks results)))))))) (length '('ribcage symnames marks labels))))
(scan-list-rib (if (eq? (vector-ref vx 0) 'ribcage)
(lambda (subst symnames marks results) (let* ((symnames (vector-ref vx (#{1+}# 0)))
(let f ((symnames symnames) (marks marks) (results results)) (marks (vector-ref vx (#{1+}# (#{1+}# 0))))
(if (null? symnames) (labels (vector-ref vx (#{1+}# (#{1+}# (#{1+}# 0)))))
(scan (cdr subst) results) (subst* vy))
(f (cdr symnames) (letrec* ((scan-list-rib
(cdr marks) (lambda ()
(cons (wrap (car symnames) (anti-mark (make-wrap (car marks) subst)) mod) results)))))) (let lp ((symnames symnames)
(scan-vector-rib (marks marks)
(lambda (subst symnames marks results) (results results))
(let ((n (vector-length symnames))) (let* ((v symnames)
(let f ((i 0) (results results)) (fk (lambda ()
(if (= i n) (let ((fk (lambda ()
(scan (cdr subst) results) (error "value failed to match"
(f (#{1+}# i) v))))
(cons (wrap (vector-ref symnames i) (if (pair? v)
(anti-mark (make-wrap (vector-ref marks i) subst)) (let ((vx (car v))
mod) (vy (cdr v)))
results)))))))) (let* ((sym vx)
(scan (wrap-subst w) '())))) (symnames vy)
(v marks)
(fk (lambda ()
(error "value failed to match"
v))))
(if (pair? v)
(let ((vx (car v))
(vy (cdr v)))
(let* ((m vx)
(marks vy))
(lp symnames
marks
(cons (wrap sym
(anti-mark
(make-wrap
m
subst))
mod)
results))))
(fk))))
(fk))))))
(if (null? v) (scan subst* results) (fk))))))
(scan-vector-rib
(lambda ()
(let ((n (vector-length symnames)))
(let lp ((i 0) (results results))
(if (= i n)
(scan subst* results)
(lp (#{1+}# i)
(let ((sym (vector-ref symnames i))
(m (vector-ref marks i)))
(cons (wrap sym
(anti-mark
(make-wrap m subst))
mod)
results)))))))))
(if (vector? symnames) (scan-vector-rib) (scan-list-rib))))
(fk))
(fk)))
(fk))))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(if (eq? vx 'shift) (let ((subst vy)) (scan subst results)) (fk)))
(fk))))))
(if (null? v) results (fk))))))
(resolve-identifier (resolve-identifier
(lambda (id w r mod resolve-syntax-parameters?) (lambda (id w r mod resolve-syntax-parameters?)
(letrec* ((resolve-global (letrec* ((resolve-global
@ -1021,11 +1065,11 @@
(source-wrap e w (wrap-subst w) mod) (source-wrap e w (wrap-subst w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-fa5 transformer-environment) (let* ((t-680b775fb37a463-fef transformer-environment)
(t-680b775fb37a463-fa6 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-ff0 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-fa5 t-680b775fb37a463-fef
t-680b775fb37a463-fa6 t-680b775fb37a463-ff0
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -1555,11 +1599,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-2 (map (lambda (tmp-680b775fb37a463-125d
tmp-680b775fb37a463-1 tmp-680b775fb37a463-125c
tmp-680b775fb37a463) tmp-680b775fb37a463-125b)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-125b
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463-125c tmp-680b775fb37a463-125d)))
e2* e2*
e1* e1*
args*))) args*)))
@ -2654,9 +2698,8 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-132e tmp-680b775fb37a463-132d tmp-680b775fb37a463-132c) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-132c tmp-680b775fb37a463-132d) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
tmp-680b775fb37a463-132e))
template template
pattern pattern
keyword))) keyword)))
@ -2671,8 +2714,8 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-138f)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2)) (list (cons tmp-680b775fb37a463-138f tmp-680b775fb37a463) tmp-680b775fb37a463-1))
template template
pattern pattern
keyword))) keyword)))
@ -2684,11 +2727,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463 (map (lambda (tmp-680b775fb37a463-13aa
tmp-680b775fb37a463-135f tmp-680b775fb37a463-13a9
tmp-680b775fb37a463-135e) tmp-680b775fb37a463-13a8)
(list (cons tmp-680b775fb37a463-135e tmp-680b775fb37a463-135f) (list (cons tmp-680b775fb37a463-13a8 tmp-680b775fb37a463-13a9)
tmp-680b775fb37a463)) tmp-680b775fb37a463-13aa))
template template
pattern pattern
keyword))) keyword)))
@ -2704,11 +2747,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-137f (map (lambda (tmp-680b775fb37a463-13c9
tmp-680b775fb37a463-137e tmp-680b775fb37a463-13c8
tmp-680b775fb37a463-137d) tmp-680b775fb37a463-13c7)
(list (cons tmp-680b775fb37a463-137d tmp-680b775fb37a463-137e) (list (cons tmp-680b775fb37a463-13c7 tmp-680b775fb37a463-13c8)
tmp-680b775fb37a463-137f)) tmp-680b775fb37a463-13c9))
template template
pattern pattern
keyword))) keyword)))
@ -2836,9 +2879,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-142c) (map (lambda (tmp-680b775fb37a463)
(list "value" (list "value" tmp-680b775fb37a463))
tmp-680b775fb37a463-142c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2864,9 +2906,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-147b)
(list "value" (list "value"
tmp-680b775fb37a463)) tmp-680b775fb37a463-147b))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2923,8 +2965,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-144c) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-144c)) (list "value" tmp-680b775fb37a463))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3006,7 +3048,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) (apply (lambda (t-680b775fb37a463-14df)
(cons "vector" t-680b775fb37a463-14df))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3016,8 +3059,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-14a1) (k (map (lambda (tmp-680b775fb37a463-14eb)
(list "quote" tmp-680b775fb37a463-14a1)) (list "quote" tmp-680b775fb37a463-14eb))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3028,8 +3071,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-14b0 tmp)) (let ((t-680b775fb37a463-14fa tmp))
(list "list->vector" t-680b775fb37a463-14b0))))))))))))))))) (list "list->vector" t-680b775fb37a463-14fa)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3041,9 +3084,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-14bf) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-14bf)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3059,14 +3102,14 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-14d3 (apply (lambda (t-680b775fb37a463-151d
t-680b775fb37a463-14d2) t-680b775fb37a463-151c)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-14d3 t-680b775fb37a463-151d
t-680b775fb37a463-14d2)) t-680b775fb37a463-151c))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3079,12 +3122,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-14df) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-14df)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3097,12 +3140,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-14eb) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-14eb)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3113,12 +3156,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-14f7 tmp)) (let ((t-680b775fb37a463 tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-14f7)))) t-680b775fb37a463))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

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

@ -708,39 +708,34 @@
;; marks to them. ;; marks to them.
;; ;;
(define (locally-bound-identifiers w mod) (define (locally-bound-identifiers w mod)
(define scan (define (scan subst results)
(lambda (subst results) (match subst
(if (null? subst) (() results)
results (('shift . subst) (scan subst results))
(let ((fst (car subst))) ((#('ribcage symnames marks labels) . subst*)
(if (eq? fst 'shift) (define (scan-list-rib)
(scan (cdr subst) results) (let lp ((symnames symnames) (marks marks) (results results))
(let ((symnames (ribcage-symnames fst)) (match symnames
(marks (ribcage-marks fst))) (() (scan subst* results))
(if (vector? symnames) ((sym . symnames)
(scan-vector-rib subst symnames marks results) (match marks
(scan-list-rib subst symnames marks results)))))))) ((m . marks)
(define scan-list-rib (lp symnames marks
(lambda (subst symnames marks results) (cons (wrap sym (anti-mark (make-wrap m subst)) mod)
(let f ((symnames symnames) (marks marks) (results results)) results))))))))
(if (null? symnames) (define (scan-vector-rib)
(scan (cdr subst) results) (let ((n (vector-length symnames)))
(f (cdr symnames) (cdr marks) (let lp ((i 0) (results results))
(cons (wrap (car symnames) (if (= i n)
(anti-mark (make-wrap (car marks) subst)) (scan subst* results)
mod) (lp (1+ i)
results)))))) (let ((sym (vector-ref symnames i))
(define scan-vector-rib (m (vector-ref marks i)))
(lambda (subst symnames marks results) (cons (wrap sym (anti-mark (make-wrap m subst)) mod)
(let ((n (vector-length symnames))) results)))))))
(let f ((i 0) (results results)) (if (vector? symnames)
(if (= i n) (scan-vector-rib)
(scan (cdr subst) results) (scan-list-rib)))))
(f (1+ i)
(cons (wrap (vector-ref symnames i)
(anti-mark (make-wrap (vector-ref marks i) subst))
mod)
results)))))))
(scan (wrap-subst w) '())) (scan (wrap-subst w) '()))
;; Returns three values: binding type, binding value, and the module ;; Returns three values: binding type, binding value, and the module