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 output constructors.

Browse source 
* module/ice-9/psyntax.scm: Eta-reduce build-void, build-call, et al.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-19 14:23:47 +01:00
parent 7379049d30
commit 2f684989e1
2 changed files with 82 additions and 119 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -122,11 +122,10 @@
(let ((meta (lambda-meta val))) (let ((meta (lambda-meta val)))
(if (assq 'name meta) val (make-lambda (lambda-src val) (acons 'name name meta) (lambda-body val)))) (if (assq 'name meta) val (make-lambda (lambda-src val) (acons 'name name meta) (lambda-body val))))
val))) val)))
(build-void (lambda (sourcev) (make-void sourcev))) (build-void make-void)
(build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev fun-exp arg-exps))) (build-call make-call)
(build-conditional (build-conditional make-conditional)
(lambda (sourcev test-exp then-exp else-exp) (make-conditional sourcev test-exp then-exp else-exp))) (build-lexical-reference make-lexical-ref)
(build-lexical-reference (lambda (sourcev name var) (make-lexical-ref sourcev name var)))
(build-lexical-assignment (build-lexical-assignment
(lambda (sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp)))) (lambda (sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp))))
(analyze-variable (analyze-variable
@ -182,13 +181,11 @@
(build-simple-lambda (build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
(make-lambda src meta (make-lambda-case src req #f rest #f '() vars exp #f)))) (make-lambda src meta (make-lambda-case src req #f rest #f '() vars exp #f))))
(build-case-lambda (lambda (src meta body) (make-lambda src meta body))) (build-case-lambda make-lambda)
(build-lambda-case (build-lambda-case make-lambda-case)
(lambda (src req opt rest kw inits vars body else-case) (build-primcall make-primcall)
(make-lambda-case src req opt rest kw inits vars body else-case))) (build-primref make-primitive-ref)
(build-primcall (lambda (src name args) (make-primcall src name args))) (build-data make-const)
(build-primref (lambda (src name) (make-primitive-ref src name)))
(build-data (lambda (src exp) (make-const src exp)))
(build-sequence (build-sequence
(lambda (src exps) (lambda (src exps)
(let* ((v exps) (let* ((v exps)
@ -1200,11 +1197,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-cc2 transformer-environment) (let* ((t-680b775fb37a463-c86 transformer-environment)
(t-680b775fb37a463-cc3 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-c87 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-cc2 t-680b775fb37a463-c86
t-680b775fb37a463-cc3 t-680b775fb37a463-c87
(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)
@ -1735,11 +1732,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-f4b (map (lambda (tmp-680b775fb37a463-f0f
tmp-680b775fb37a463-f4a tmp-680b775fb37a463-f0e
tmp-680b775fb37a463-f49) tmp-680b775fb37a463-f0d)
(cons tmp-680b775fb37a463-f49 (cons tmp-680b775fb37a463-f0d
(cons tmp-680b775fb37a463-f4a tmp-680b775fb37a463-f4b))) (cons tmp-680b775fb37a463-f0e tmp-680b775fb37a463-f0f)))
e2* e2*
e1* e1*
args*))) args*)))
@ -2012,11 +2009,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-11b0 (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-11af (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
tmp-680b775fb37a463-11ae)
(cons tmp-680b775fb37a463-11ae
(cons tmp-680b775fb37a463-11af tmp-680b775fb37a463-11b0)))
e2 e2
e1 e1
args))) args)))
@ -2026,11 +2020,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-11c6 (map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-11c5 (cons tmp-680b775fb37a463
tmp-680b775fb37a463-11c4) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-118a)))
(cons tmp-680b775fb37a463-11c4
(cons tmp-680b775fb37a463-11c5 tmp-680b775fb37a463-11c6)))
e2 e2
e1 e1
args))) args)))
@ -2048,11 +2040,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-11e6 (map (lambda (tmp-680b775fb37a463-11aa
tmp-680b775fb37a463-11e5 tmp-680b775fb37a463-11a9
tmp-680b775fb37a463-11e4) tmp-680b775fb37a463-11a8)
(cons tmp-680b775fb37a463-11e4 (cons tmp-680b775fb37a463-11a8
(cons tmp-680b775fb37a463-11e5 tmp-680b775fb37a463-11e6))) (cons tmp-680b775fb37a463-11a9 tmp-680b775fb37a463-11aa)))
e2 e2
e1 e1
args))) args)))
@ -2062,11 +2054,11 @@
(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-11fc (map (lambda (tmp-680b775fb37a463-11c0
tmp-680b775fb37a463-11fb tmp-680b775fb37a463-11bf
tmp-680b775fb37a463-11fa) tmp-680b775fb37a463-11be)
(cons tmp-680b775fb37a463-11fa (cons tmp-680b775fb37a463-11be
(cons tmp-680b775fb37a463-11fb tmp-680b775fb37a463-11fc))) (cons tmp-680b775fb37a463-11bf tmp-680b775fb37a463-11c0)))
e2 e2
e1 e1
args))) args)))
@ -2876,9 +2868,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-14da tmp-680b775fb37a463-14d9 tmp-680b775fb37a463-14d8) (map (lambda (tmp-680b775fb37a463-149e tmp-680b775fb37a463-149d tmp-680b775fb37a463-149c)
(list (cons tmp-680b775fb37a463-14d8 tmp-680b775fb37a463-14d9) (list (cons tmp-680b775fb37a463-149c tmp-680b775fb37a463-149d)
tmp-680b775fb37a463-14da)) tmp-680b775fb37a463-149e))
template template
pattern pattern
keyword))) keyword)))
@ -2893,11 +2885,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-14f3 (map (lambda (tmp-680b775fb37a463-14b7
tmp-680b775fb37a463-14f2 tmp-680b775fb37a463-14b6
tmp-680b775fb37a463-14f1) tmp-680b775fb37a463-14b5)
(list (cons tmp-680b775fb37a463-14f1 tmp-680b775fb37a463-14f2) (list (cons tmp-680b775fb37a463-14b5 tmp-680b775fb37a463-14b6)
tmp-680b775fb37a463-14f3)) tmp-680b775fb37a463-14b7))
template template
pattern pattern
keyword))) keyword)))
@ -2909,11 +2901,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-150c (map (lambda (tmp-680b775fb37a463-14d0
tmp-680b775fb37a463-150b tmp-680b775fb37a463-14cf
tmp-680b775fb37a463-150a) tmp-680b775fb37a463-14ce)
(list (cons tmp-680b775fb37a463-150a tmp-680b775fb37a463-150b) (list (cons tmp-680b775fb37a463-14ce tmp-680b775fb37a463-14cf)
tmp-680b775fb37a463-150c)) tmp-680b775fb37a463-14d0))
template template
pattern pattern
keyword))) keyword)))
@ -2929,11 +2921,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-152b (map (lambda (tmp-680b775fb37a463-14ef
tmp-680b775fb37a463-152a tmp-680b775fb37a463-14ee
tmp-680b775fb37a463) tmp-680b775fb37a463-14ed)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-152a) (list (cons tmp-680b775fb37a463-14ed tmp-680b775fb37a463-14ee)
tmp-680b775fb37a463-152b)) tmp-680b775fb37a463-14ef))
template template
pattern pattern
keyword))) keyword)))
@ -3061,9 +3053,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-15d8) (map (lambda (tmp-680b775fb37a463-159c)
(list "value" (list "value"
tmp-680b775fb37a463-15d8)) tmp-680b775fb37a463-159c))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3089,9 +3081,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-15dd) (map (lambda (tmp-680b775fb37a463-15a1)
(list "value" (list "value"
tmp-680b775fb37a463-15dd)) tmp-680b775fb37a463-15a1))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3127,8 +3119,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-15f3) (map (lambda (tmp-680b775fb37a463-15b7)
(list "value" tmp-680b775fb37a463-15f3)) (list "value" tmp-680b775fb37a463-15b7))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3148,8 +3140,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-15f8) (map (lambda (tmp-680b775fb37a463-15bc)
(list "value" tmp-680b775fb37a463-15f8)) (list "value" tmp-680b775fb37a463-15bc))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3241,8 +3233,7 @@
(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-164d) (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
(list "quote" tmp-680b775fb37a463-164d))
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))))
@ -3253,8 +3244,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-165c tmp)) (let ((t-680b775fb37a463 tmp))
(list "list->vector" t-680b775fb37a463-165c))))))))))))))))) (list "list->vector" t-680b775fb37a463)))))))))))))))))
(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))))
@ -3266,9 +3257,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-166b) (apply (lambda (t-680b775fb37a463-162f)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-166b)) t-680b775fb37a463-162f))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3284,14 +3275,13 @@
(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-167f (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
t-680b775fb37a463-167e)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-167f t-680b775fb37a463-1
t-680b775fb37a463-167e)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3304,12 +3294,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-168b) (apply (lambda (t-680b775fb37a463-164f)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-168b)) t-680b775fb37a463-164f))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3322,12 +3312,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) (apply (lambda (t-680b775fb37a463-165b)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-165b))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3338,12 +3328,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-16a3 tmp)) (let ((t-680b775fb37a463 tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-16a3)))) 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

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

@ -228,18 +228,10 @@
val)) val))
;; output constructors ;; output constructors
(define (build-void sourcev) (define build-void make-void)
(make-void sourcev)) (define build-call make-call)
(define build-conditional make-conditional)
(define (build-call sourcev fun-exp arg-exps) (define build-lexical-reference make-lexical-ref)
(make-call sourcev fun-exp arg-exps))
(define (build-conditional sourcev test-exp then-exp else-exp)
(make-conditional sourcev test-exp then-exp else-exp))
(define (build-lexical-reference sourcev name var)
(make-lexical-ref sourcev name var))
(define (build-lexical-assignment sourcev name var exp) (define (build-lexical-assignment sourcev name var exp)
(make-lexical-set sourcev name var (maybe-name-value name exp))) (make-lexical-set sourcev name var (maybe-name-value name exp)))
@ -283,30 +275,11 @@
;; src req opt rest kw inits vars body else ;; src req opt rest kw inits vars body else
src req #f rest #f '() vars exp #f))) src req #f rest #f '() vars exp #f)))
(define (build-case-lambda src meta body) (define build-case-lambda make-lambda)
(make-lambda src meta body)) (define build-lambda-case make-lambda-case)
(define build-primcall make-primcall)
(define (build-lambda-case src req opt rest kw inits vars body else-case) (define build-primref make-primitive-ref)
;; req := (name ...) (define build-data make-const)
;; opt := (name ...) | #f
;; rest := name | #f
;; kw := (allow-other-keys? (keyword name var) ...) | #f
;; inits: (init ...)
;; vars: (sym ...)
;; vars map to named arguments in the following order:
;; required, optional (positional), rest, keyword.
;; the body of a lambda: anything, already expanded
;; else: lambda-case | #f
(make-lambda-case src req opt rest kw inits vars body else-case))
(define (build-primcall src name args)
(make-primcall src name args))
(define (build-primref src name)
(make-primitive-ref src name))
(define (build-data src exp)
(make-const src exp))
(define (build-sequence src exps) (define (build-sequence src exps)
(match exps (match exps