mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
psyntax: Simplify output constructors.
* 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
parent
7379049d30
commit
2f684989e1
2 changed files with 82 additions and 119 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue