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 to first-order bindings. NFC

Browse source 
* module/ice-9/psyntax.scm (no-source, make-empty-ribcage): Make normal
bindings, not macros.
This commit is contained in:
Andy Wingo 2024-11-18 15:16:55 +01:00
parent 522b0b4510
commit 527b4498a8
2 changed files with 84 additions and 82 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -183,6 +183,7 @@
(make-letrec src in-order? ids vars val-exps body-exp))))) (make-letrec src in-order? ids vars val-exps body-exp)))))
(if (null? v) body-exp (fk))))) (if (null? v) body-exp (fk)))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id)))) (gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(no-source #f)
(datum-sourcev (datum-sourcev
(lambda (datum) (lambda (datum)
(let ((props (source-properties datum))) (let ((props (source-properties datum)))
@ -297,6 +298,7 @@
(the-anti-mark #f) (the-anti-mark #f)
(anti-mark (lambda (w) (make-wrap (cons the-anti-mark (wrap-marks w)) (cons 'shift (wrap-subst w))))) (anti-mark (lambda (w) (make-wrap (cons the-anti-mark (wrap-marks w)) (cons 'shift (wrap-subst w)))))
(new-mark (lambda () (gen-unique))) (new-mark (lambda () (gen-unique)))
(make-empty-ribcage (lambda () (make-ribcage '() '() '())))
(extend-ribcage! (extend-ribcage!
(lambda (ribcage id label) (lambda (ribcage id label)
(set-ribcage-symnames! ribcage (cons (syntax-expression id) (ribcage-symnames ribcage))) (set-ribcage-symnames! ribcage (cons (syntax-expression id) (ribcage-symnames ribcage)))
@ -703,7 +705,7 @@
(expand-top-sequence (expand-top-sequence
(lambda (body r w s m esew mod) (lambda (body r w s m esew mod)
(let* ((r (cons '("placeholder" placeholder) r)) (let* ((r (cons '("placeholder" placeholder) r))
(ribcage (make-ribcage '() '() '())) (ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
(letrec* ((record-definition! (letrec* ((record-definition!
(lambda (id var) (lambda (id var)
@ -899,14 +901,14 @@
(expand-install-global (expand-install-global
(lambda (mod name type e) (lambda (mod name type e)
(build-global-definition (build-global-definition
#f no-source
mod mod
name name
(build-primcall (build-primcall
#f no-source
'make-syntax-transformer 'make-syntax-transformer
(list (build-data #f name) (list (build-data no-source name)
(build-data #f (if (eq? type 'define-syntax-parameter-form) 'syntax-parameter 'macro)) (build-data no-source (if (eq? type 'define-syntax-parameter-form) 'syntax-parameter 'macro))
e))))) e)))))
(parse-when-list (parse-when-list
(lambda (e when-list) (lambda (e when-list)
@ -1152,16 +1154,16 @@
(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-10d6 transformer-environment) (let* ((t-680b775fb37a463-10a5 transformer-environment)
(t-680b775fb37a463-10d7 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-10a6 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-10d6 t-680b775fb37a463-10a5
t-680b775fb37a463-10d7 t-680b775fb37a463-10a6
(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)
(let* ((r (cons '("placeholder" placeholder) r)) (let* ((r (cons '("placeholder" placeholder) r))
(ribcage (make-ribcage '() '() '())) (ribcage (make-empty-ribcage))
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst 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)) (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
(ids '()) (ids '())
@ -1310,7 +1312,7 @@
(let ((p (local-eval expanded mod))) (let ((p (local-eval expanded mod)))
(if (not (procedure? p)) (syntax-violation #f "nonprocedure transformer" p)) (if (not (procedure? p)) (syntax-violation #f "nonprocedure transformer" p))
p))) p)))
(expand-void (lambda () (build-void #f))) (expand-void (lambda () (build-void no-source)))
(ellipsis? (ellipsis?
(lambda (e r mod) (lambda (e r mod)
(and (nonsymbol-id? e) (and (nonsymbol-id? e)
@ -1687,11 +1689,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-1 (map (lambda (tmp-680b775fb37a463-132e
tmp-680b775fb37a463 tmp-680b775fb37a463-132d
tmp-680b775fb37a463-135f) tmp-680b775fb37a463-132c)
(cons tmp-680b775fb37a463-135f (cons tmp-680b775fb37a463-132c
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) (cons tmp-680b775fb37a463-132d tmp-680b775fb37a463-132e)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1893,14 +1895,14 @@
(regen (lambda (x) (regen (lambda (x)
(let ((key (car x))) (let ((key (car x)))
(cond (cond
((memv key '(ref)) (build-lexical-reference #f (cadr x) (cadr x))) ((memv key '(ref)) (build-lexical-reference no-source (cadr x) (cadr x)))
((memv key '(primitive)) (build-primref #f (cadr x))) ((memv key '(primitive)) (build-primref no-source (cadr x)))
((memv key '(quote)) (build-data #f (cadr x))) ((memv key '(quote)) (build-data no-source (cadr x)))
((memv key '(lambda)) ((memv key '(lambda))
(if (list? (cadr x)) (if (list? (cadr x))
(build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x))) (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x))) (error "how did we get here" x)))
(else (build-primcall #f (car x) (map regen (cdr x))))))))) (else (build-primcall no-source (car x) (map regen (cdr x)))))))))
(lambda (e r w s mod) (lambda (e r w s mod)
(let* ((e (source-wrap e w s mod)) (tmp e) (tmp ($sc-dispatch tmp '(_ any)))) (let* ((e (source-wrap e w s mod)) (tmp e) (tmp ($sc-dispatch tmp '(_ any))))
(if tmp (if tmp
@ -1959,8 +1961,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-6bf tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bd) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-6bd (cons tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bf))) (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2 e2
e1 e1
args))) args)))
@ -1970,9 +1972,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-6d5 tmp-680b775fb37a463-6d4 tmp-680b775fb37a463-6d3) (map (lambda (tmp-680b775fb37a463-6ae tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ac)
(cons tmp-680b775fb37a463-6d3 (cons tmp-680b775fb37a463-6ac
(cons tmp-680b775fb37a463-6d4 tmp-680b775fb37a463-6d5))) (cons tmp-680b775fb37a463-6ad tmp-680b775fb37a463-6ae)))
e2 e2
e1 e1
args))) args)))
@ -2003,9 +2005,8 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-69f tmp-680b775fb37a463-69e tmp-680b775fb37a463-69d) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463-69d (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
(cons tmp-680b775fb37a463-69e tmp-680b775fb37a463-69f)))
e2 e2
e1 e1
args))) args)))
@ -2130,7 +2131,7 @@
(if tmp (if tmp
(apply (lambda (head tail val) (apply (lambda (head tail val)
(call-with-values (call-with-values
(lambda () (syntax-type head r empty-wrap #f #f mod #t)) (lambda () (syntax-type head r empty-wrap no-source #f mod #t))
(lambda (type value ee* ee ww ss modmod) (lambda (type value ee* ee ww ss modmod)
(let ((key type)) (let ((key type))
(if (memv key '(module-ref)) (if (memv key '(module-ref))
@ -2224,7 +2225,7 @@
(let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
(if tmp-1 (if tmp-1
(apply (lambda (test then) (apply (lambda (test then)
(build-conditional s (expand test r w mod) (expand then r w mod) (build-void #f))) (build-conditional s (expand test r w mod) (expand then r w mod) (build-void no-source)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
(if tmp-1 (if tmp-1
@ -2314,10 +2315,10 @@
(let ((ids (map car pvars)) (levels (map cdr pvars))) (let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-primcall (build-primcall
#f no-source
'apply 'apply
(list (build-simple-lambda (list (build-simple-lambda
#f no-source
(map syntax->datum ids) (map syntax->datum ids)
#f #f
new-vars new-vars
@ -2343,36 +2344,38 @@
(syntax-violation 'syntax-case "duplicate pattern variable" pat)) (syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else (let ((y (gen-var 'tmp))) (else (let ((y (gen-var 'tmp)))
(build-call (build-call
#f no-source
(build-simple-lambda (build-simple-lambda
#f no-source
(list 'tmp) (list 'tmp)
#f #f
(list y) (list y)
'() '()
(let ((y (build-lexical-reference #f 'tmp y))) (let ((y (build-lexical-reference no-source 'tmp y)))
(build-conditional (build-conditional
#f no-source
(let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
(if tmp (if tmp
(apply (lambda () y) tmp) (apply (lambda () y) tmp)
(build-conditional (build-conditional
#f no-source
y y
(build-dispatch-call pvars fender y r mod) (build-dispatch-call pvars fender y r mod)
(build-data #f #f)))) (build-data no-source #f))))
(build-dispatch-call pvars exp y r mod) (build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod)))) (gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any) (list (if (eq? p 'any)
(build-primcall #f 'list (list x)) (build-primcall no-source 'list (list x))
(build-primcall #f '$sc-dispatch (list x (build-data #f p))))))))))))) (build-primcall no-source '$sc-dispatch (list x (build-data no-source p)))))))))))))
(gen-syntax-case (gen-syntax-case
(lambda (x keys clauses r mod) (lambda (x keys clauses r mod)
(if (null? clauses) (if (null? clauses)
(build-primcall (build-primcall
#f no-source
'syntax-violation 'syntax-violation
(list (build-data #f #f) (build-data #f "source expression failed to match any pattern") x)) (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)))) (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (pat exp) (apply (lambda (pat exp)
@ -2384,9 +2387,9 @@
(expand exp r empty-wrap mod) (expand exp r empty-wrap mod)
(let ((labels (list (gen-label))) (var (gen-var pat))) (let ((labels (list (gen-label))) (var (gen-var pat)))
(build-call (build-call
#f no-source
(build-simple-lambda (build-simple-lambda
#f no-source
(list (syntax->datum pat)) (list (syntax->datum pat))
#f #f
(list var) (list var)
@ -2414,12 +2417,12 @@
(build-call (build-call
s s
(build-simple-lambda (build-simple-lambda
#f no-source
(list 'tmp) (list 'tmp)
#f #f
(list x) (list x)
'() '()
(gen-syntax-case (build-lexical-reference #f 'tmp x) key m r mod)) (gen-syntax-case (build-lexical-reference no-source 'tmp x) key m r mod))
(list (expand val r empty-wrap mod)))) (list (expand val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))) (syntax-violation 'syntax-case "invalid literals list" e)))
tmp) tmp)
@ -2786,9 +2789,8 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-147c tmp-680b775fb37a463-147b tmp-680b775fb37a463-147a) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-147a tmp-680b775fb37a463-147b) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
tmp-680b775fb37a463-147c))
template template
pattern pattern
keyword))) keyword)))
@ -2816,11 +2818,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-14ae (map (lambda (tmp-680b775fb37a463-147b
tmp-680b775fb37a463-14ad tmp-680b775fb37a463-147a
tmp-680b775fb37a463-14ac) tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-147a)
tmp-680b775fb37a463-14ae)) tmp-680b775fb37a463-147b))
template template
pattern pattern
keyword))) keyword)))
@ -2836,11 +2838,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-14cd (map (lambda (tmp-680b775fb37a463-149a
tmp-680b775fb37a463-14cc tmp-680b775fb37a463-1
tmp-680b775fb37a463-14cb) tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-14cb tmp-680b775fb37a463-14cc) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-14cd)) tmp-680b775fb37a463-149a))
template template
pattern pattern
keyword))) keyword)))
@ -2968,9 +2970,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-157a) (map (lambda (tmp-680b775fb37a463)
(list "value" (list "value" tmp-680b775fb37a463))
tmp-680b775fb37a463-157a))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2996,9 +2997,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-157f) (map (lambda (tmp-680b775fb37a463-154c)
(list "value" (list "value"
tmp-680b775fb37a463-157f)) tmp-680b775fb37a463-154c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3055,8 +3056,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-159a) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-159a)) (list "value" tmp-680b775fb37a463))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3138,8 +3139,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-15e3) (apply (lambda (t-680b775fb37a463-15b0)
(cons "vector" t-680b775fb37a463-15e3)) (cons "vector" t-680b775fb37a463-15b0))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3149,8 +3150,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-15ef) (k (map (lambda (tmp-680b775fb37a463-15bc)
(list "quote" tmp-680b775fb37a463-15ef)) (list "quote" tmp-680b775fb37a463-15bc))
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))))
@ -3161,8 +3162,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-15fe tmp)) (let ((t-680b775fb37a463-15cb tmp))
(list "list->vector" t-680b775fb37a463-15fe))))))))))))))))) (list "list->vector" t-680b775fb37a463-15cb)))))))))))))))))
(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))))
@ -3174,9 +3175,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-160d) (apply (lambda (t-680b775fb37a463-15da)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-160d)) t-680b775fb37a463-15da))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3192,13 +3193,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-1 t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-15ee
t-680b775fb37a463-15ed)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-1 t-680b775fb37a463-15ee
t-680b775fb37a463)) t-680b775fb37a463-15ed))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3211,12 +3213,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-162d) (apply (lambda (t-680b775fb37a463-15fa)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-162d)) t-680b775fb37a463-15fa))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

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

@ -327,7 +327,7 @@
;; that the generated identifier is reproducible. ;; that the generated identifier is reproducible.
(module-gensym (symbol->string id))) (module-gensym (symbol->string id)))
(define-syntax no-source (identifier-syntax #f)) (define no-source #f)
(define (datum-sourcev datum) (define (datum-sourcev datum)
(let ((props (source-properties datum))) (let ((props (source-properties datum)))
@ -546,7 +546,7 @@
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally ;; internal definitions, in which the ribcages are built incrementally
(define-syntax-rule (make-empty-ribcage) (define (make-empty-ribcage)
(make-ribcage '() '() '())) (make-ribcage '() '() '()))
(define (extend-ribcage! ribcage id label) (define (extend-ribcage! ribcage id label)