|
| From: | Andy Wingo |
| Subject: | [Guile-commits] 03/09: psyntax: Simplify output constructors. |
| Date: | Mon, 25 Nov 2024 05:47:43 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit 2f684989e1c42638fe64e12669b9f18129e4dd06
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Nov 19 14:23:47 2024 +0100
psyntax: Simplify output constructors.
* module/ice-9/psyntax.scm: Eta-reduce build-void, build-call, et al.
* module/ice-9/psyntax-pp.scm: Regenerate.
---
module/ice-9/psyntax-pp.scm | 156 +++++++++++++++++++++-----------------------
module/ice-9/psyntax.scm | 45 +++----------
2 files changed, 82 insertions(+), 119 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 0d86fabf1..858b9ec2a 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -122,11 +122,10 @@
(let ((meta (lambda-meta val)))
(if (assq 'name meta) val (make-lambda (lambda-src val)
(acons 'name name meta) (lambda-body val))))
val)))
- (build-void (lambda (sourcev) (make-void sourcev)))
- (build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev
fun-exp arg-exps)))
- (build-conditional
- (lambda (sourcev test-exp then-exp else-exp) (make-conditional
sourcev test-exp then-exp else-exp)))
- (build-lexical-reference (lambda (sourcev name var)
(make-lexical-ref sourcev name var)))
+ (build-void make-void)
+ (build-call make-call)
+ (build-conditional make-conditional)
+ (build-lexical-reference make-lexical-ref)
(build-lexical-assignment
(lambda (sourcev name var exp) (make-lexical-set sourcev name var
(maybe-name-value name exp))))
(analyze-variable
@@ -182,13 +181,11 @@
(build-simple-lambda
(lambda (src req rest vars meta exp)
(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-lambda-case
- (lambda (src req opt rest kw inits vars body else-case)
- (make-lambda-case src req opt rest kw inits vars body
else-case)))
- (build-primcall (lambda (src name args) (make-primcall src name
args)))
- (build-primref (lambda (src name) (make-primitive-ref src name)))
- (build-data (lambda (src exp) (make-const src exp)))
+ (build-case-lambda make-lambda)
+ (build-lambda-case make-lambda-case)
+ (build-primcall make-primcall)
+ (build-primref make-primitive-ref)
+ (build-data make-const)
(build-sequence
(lambda (src exps)
(let* ((v exps)
@@ -1200,11 +1197,11 @@
(source-wrap e w (wrap-subst w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-cc2 transformer-environment)
- (t-680b775fb37a463-cc3 (lambda (k) (k e r w s rib
mod))))
+ (let* ((t-680b775fb37a463-c86 transformer-environment)
+ (t-680b775fb37a463-c87 (lambda (k) (k e r w s rib
mod))))
(with-fluid*
- t-680b775fb37a463-cc2
- t-680b775fb37a463-cc3
+ t-680b775fb37a463-c86
+ t-680b775fb37a463-c87
(lambda () (rebuild-macro-output (p (source-wrap e
(anti-mark w) s mod)) (new-mark))))))))
(expand-body
(lambda (body outer-form r w mod)
@@ -1735,11 +1732,11 @@
s
mod
get-formals
- (map (lambda
(tmp-680b775fb37a463-f4b
-
tmp-680b775fb37a463-f4a
-
tmp-680b775fb37a463-f49)
- (cons
tmp-680b775fb37a463-f49
- (cons
tmp-680b775fb37a463-f4a tmp-680b775fb37a463-f4b)))
+ (map (lambda
(tmp-680b775fb37a463-f0f
+
tmp-680b775fb37a463-f0e
+
tmp-680b775fb37a463-f0d)
+ (cons
tmp-680b775fb37a463-f0d
+ (cons
tmp-680b775fb37a463-f0e tmp-680b775fb37a463-f0f)))
e2*
e1*
args*)))
@@ -2012,11 +2009,8 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-11b0
- tmp-680b775fb37a463-11af
- tmp-680b775fb37a463-11ae)
- (cons tmp-680b775fb37a463-11ae
- (cons tmp-680b775fb37a463-11af
tmp-680b775fb37a463-11b0)))
+ (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2
e1
args)))
@@ -2026,11 +2020,9 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation
(syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-11c6
- tmp-680b775fb37a463-11c5
- tmp-680b775fb37a463-11c4)
- (cons tmp-680b775fb37a463-11c4
- (cons
tmp-680b775fb37a463-11c5 tmp-680b775fb37a463-11c6)))
+ (map (lambda (tmp-680b775fb37a463-118a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463
+ (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-118a)))
e2
e1
args)))
@@ -2048,11 +2040,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-11e6
- tmp-680b775fb37a463-11e5
- tmp-680b775fb37a463-11e4)
- (cons tmp-680b775fb37a463-11e4
- (cons tmp-680b775fb37a463-11e5
tmp-680b775fb37a463-11e6)))
+ (map (lambda (tmp-680b775fb37a463-11aa
+ tmp-680b775fb37a463-11a9
+ tmp-680b775fb37a463-11a8)
+ (cons tmp-680b775fb37a463-11a8
+ (cons tmp-680b775fb37a463-11a9
tmp-680b775fb37a463-11aa)))
e2
e1
args)))
@@ -2062,11 +2054,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation
(syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-11fc
- tmp-680b775fb37a463-11fb
- tmp-680b775fb37a463-11fa)
- (cons tmp-680b775fb37a463-11fa
- (cons
tmp-680b775fb37a463-11fb tmp-680b775fb37a463-11fc)))
+ (map (lambda (tmp-680b775fb37a463-11c0
+ tmp-680b775fb37a463-11bf
+ tmp-680b775fb37a463-11be)
+ (cons tmp-680b775fb37a463-11be
+ (cons
tmp-680b775fb37a463-11bf tmp-680b775fb37a463-11c0)))
e2
e1
args)))
@@ -2876,9 +2868,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-14da
tmp-680b775fb37a463-14d9 tmp-680b775fb37a463-14d8)
- (list (cons tmp-680b775fb37a463-14d8
tmp-680b775fb37a463-14d9)
- tmp-680b775fb37a463-14da))
+ (map (lambda (tmp-680b775fb37a463-149e
tmp-680b775fb37a463-149d tmp-680b775fb37a463-149c)
+ (list (cons tmp-680b775fb37a463-149c
tmp-680b775fb37a463-149d)
+ tmp-680b775fb37a463-149e))
template
pattern
keyword)))
@@ -2893,11 +2885,11 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-14f3
- tmp-680b775fb37a463-14f2
- tmp-680b775fb37a463-14f1)
- (list (cons tmp-680b775fb37a463-14f1
tmp-680b775fb37a463-14f2)
- tmp-680b775fb37a463-14f3))
+ (map (lambda (tmp-680b775fb37a463-14b7
+ tmp-680b775fb37a463-14b6
+ tmp-680b775fb37a463-14b5)
+ (list (cons tmp-680b775fb37a463-14b5
tmp-680b775fb37a463-14b6)
+ tmp-680b775fb37a463-14b7))
template
pattern
keyword)))
@@ -2909,11 +2901,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-150c
- tmp-680b775fb37a463-150b
- tmp-680b775fb37a463-150a)
- (list (cons
tmp-680b775fb37a463-150a tmp-680b775fb37a463-150b)
- tmp-680b775fb37a463-150c))
+ (map (lambda (tmp-680b775fb37a463-14d0
+ tmp-680b775fb37a463-14cf
+ tmp-680b775fb37a463-14ce)
+ (list (cons
tmp-680b775fb37a463-14ce tmp-680b775fb37a463-14cf)
+ tmp-680b775fb37a463-14d0))
template
pattern
keyword)))
@@ -2929,11 +2921,11 @@
dots
k
(list docstring)
- (map (lambda
(tmp-680b775fb37a463-152b
-
tmp-680b775fb37a463-152a
- tmp-680b775fb37a463)
- (list (cons
tmp-680b775fb37a463 tmp-680b775fb37a463-152a)
-
tmp-680b775fb37a463-152b))
+ (map (lambda
(tmp-680b775fb37a463-14ef
+
tmp-680b775fb37a463-14ee
+
tmp-680b775fb37a463-14ed)
+ (list (cons
tmp-680b775fb37a463-14ed tmp-680b775fb37a463-14ee)
+
tmp-680b775fb37a463-14ef))
template
pattern
keyword)))
@@ -3061,9 +3053,9 @@
(apply (lambda (p)
(if (=
lev 0)
(quasilist*
-
(map (lambda (tmp-680b775fb37a463-15d8)
+
(map (lambda (tmp-680b775fb37a463-159c)
(list "value"
-
tmp-680b775fb37a463-15d8))
+
tmp-680b775fb37a463-159c))
p)
(quasi q lev))
(quasicons
@@ -3089,9 +3081,9 @@
(apply
(lambda (p)
(if (= lev 0)
(quasiappend
-
(map (lambda (tmp-680b775fb37a463-15dd)
+
(map (lambda (tmp-680b775fb37a463-15a1)
(list "value"
-
tmp-680b775fb37a463-15dd))
+
tmp-680b775fb37a463-15a1))
p)
(quasi q lev))
(quasicons
@@ -3127,8 +3119,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-15f3)
- (list "value"
tmp-680b775fb37a463-15f3))
+ (map (lambda
(tmp-680b775fb37a463-15b7)
+ (list "value"
tmp-680b775fb37a463-15b7))
p)
(vquasi q lev))
(quasicons
@@ -3148,8 +3140,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-15f8)
- (list
"value" tmp-680b775fb37a463-15f8))
+ (map (lambda
(tmp-680b775fb37a463-15bc)
+ (list
"value" tmp-680b775fb37a463-15bc))
p)
(vquasi q lev))
(quasicons
@@ -3241,8 +3233,7 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda
(tmp-680b775fb37a463-164d)
- (list "quote"
tmp-680b775fb37a463-164d))
+ (k (map (lambda
(tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
y)))
tmp-1)
(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)
(let ((else tmp))
(let ((tmp x))
- (let
((t-680b775fb37a463-165c tmp))
- (list "list->vector"
t-680b775fb37a463-165c)))))))))))))))))
+ (let ((t-680b775fb37a463
tmp))
+ (list "list->vector"
t-680b775fb37a463)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
any))))
@@ -3266,9 +3257,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-166b)
+ (apply (lambda
(t-680b775fb37a463-162f)
(cons
(make-syntax 'list '((top)) '(hygiene guile))
-
t-680b775fb37a463-166b))
+
t-680b775fb37a463-162f))
tmp)
(syntax-violation
#f
@@ -3284,14 +3275,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-167f
-
t-680b775fb37a463-167e)
+ (apply
(lambda (t-680b775fb37a463-1 t-680b775fb37a463)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
-
t-680b775fb37a463-167f
-
t-680b775fb37a463-167e))
+
t-680b775fb37a463-1
+
t-680b775fb37a463))
tmp)
(syntax-violation
#f
@@ -3304,12 +3294,12 @@
(let ((tmp-1 (map
emit x)))
(let ((tmp
($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply
(lambda (t-680b775fb37a463-168b)
+ (apply
(lambda (t-680b775fb37a463-164f)
(cons (make-syntax
'append
'((top))
'(hygiene guile))
-
t-680b775fb37a463-168b))
+
t-680b775fb37a463-164f))
tmp)
(syntax-violation
#f
@@ -3322,12 +3312,12 @@
(let ((tmp-1
(map emit x)))
(let ((tmp
($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply
(lambda (t-680b775fb37a463)
+ (apply
(lambda (t-680b775fb37a463-165b)
(cons (make-syntax
'vector
'((top))
'(hygiene guile))
-
t-680b775fb37a463))
+
t-680b775fb37a463-165b))
tmp)
(syntax-violation
#f
@@ -3338,12 +3328,12 @@
(if tmp-1
(apply (lambda (x)
(let
((tmp (emit x)))
- (let
((t-680b775fb37a463-16a3 tmp))
+ (let
((t-680b775fb37a463 tmp))
(list (make-syntax
'list->vector
'((top))
'(hygiene guile))
-
t-680b775fb37a463-16a3))))
+
t-680b775fb37a463))))
tmp-1)
(let ((tmp-1
($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 5a33768f4..b24e889f7 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -228,18 +228,10 @@
val))
;; output constructors
- (define (build-void sourcev)
- (make-void sourcev))
-
- (define (build-call sourcev fun-exp arg-exps)
- (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-void make-void)
+ (define build-call make-call)
+ (define build-conditional make-conditional)
+ (define build-lexical-reference make-lexical-ref)
(define (build-lexical-assignment sourcev name var 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 #f rest #f '() vars exp #f)))
- (define (build-case-lambda src meta body)
- (make-lambda src meta body))
-
- (define (build-lambda-case src req opt rest kw inits vars body else-case)
- ;; req := (name ...)
- ;; 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-case-lambda make-lambda)
+ (define build-lambda-case make-lambda-case)
+ (define build-primcall make-primcall)
+ (define build-primref make-primitive-ref)
+ (define build-data make-const)
(define (build-sequence src exps)
(match exps
| [Prev in Thread] | Current Thread | [Next in Thread] |