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

psyntax generates calls to make-struct/no-tail

Browse source 
* module/ice-9/psyntax.scm (define-expansion-constructors): Expand to
  make-struct/no-tail.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2017-09-20 21:55:21 +02:00
parent ac0d3dcc53
commit da9da0eca4
2 changed files with 97 additions and 83 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -8,27 +8,41 @@
(syntax-module (module-ref (current-module) 'syntax-module))) (syntax-module (module-ref (current-module) 'syntax-module)))
(letrec* (letrec*
((make-void ((make-void
(lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src))) (lambda (src)
(make-struct/no-tail (vector-ref %expanded-vtables 0) src)))
(make-const (make-const
(lambda (src exp) (lambda (src exp)
(make-struct (vector-ref %expanded-vtables 1) 0 src exp))) (make-struct/no-tail (vector-ref %expanded-vtables 1) src exp)))
(make-primitive-ref (make-primitive-ref
(lambda (src name) (lambda (src name)
(make-struct (vector-ref %expanded-vtables 2) 0 src name))) (make-struct/no-tail (vector-ref %expanded-vtables 2) src name)))
(make-lexical-ref (make-lexical-ref
(lambda (src name gensym) (lambda (src name gensym)
(make-struct (vector-ref %expanded-vtables 3) 0 src name gensym))) (make-struct/no-tail
(vector-ref %expanded-vtables 3)
src
name
gensym)))
(make-lexical-set (make-lexical-set
(lambda (src name gensym exp) (lambda (src name gensym exp)
(make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp))) (make-struct/no-tail
(vector-ref %expanded-vtables 4)
src
name
gensym
exp)))
(make-module-ref (make-module-ref
(lambda (src mod name public?) (lambda (src mod name public?)
(make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?))) (make-struct/no-tail
(vector-ref %expanded-vtables 5)
src
mod
name
public?)))
(make-module-set (make-module-set
(lambda (src mod name public? exp) (lambda (src mod name public? exp)
(make-struct (make-struct/no-tail
(vector-ref %expanded-vtables 6) (vector-ref %expanded-vtables 6)
0
src src
mod mod
name name
@ -36,39 +50,37 @@
exp))) exp)))
(make-toplevel-ref (make-toplevel-ref
(lambda (src name) (lambda (src name)
(make-struct (vector-ref %expanded-vtables 7) 0 src name))) (make-struct/no-tail (vector-ref %expanded-vtables 7) src name)))
(make-toplevel-set (make-toplevel-set
(lambda (src name exp) (lambda (src name exp)
(make-struct (vector-ref %expanded-vtables 8) 0 src name exp))) (make-struct/no-tail (vector-ref %expanded-vtables 8) src name exp)))
(make-toplevel-define (make-toplevel-define
(lambda (src name exp) (lambda (src name exp)
(make-struct (vector-ref %expanded-vtables 9) 0 src name exp))) (make-struct/no-tail (vector-ref %expanded-vtables 9) src name exp)))
(make-conditional (make-conditional
(lambda (src test consequent alternate) (lambda (src test consequent alternate)
(make-struct (make-struct/no-tail
(vector-ref %expanded-vtables 10) (vector-ref %expanded-vtables 10)
0
src src
test test
consequent consequent
alternate))) alternate)))
(make-call (make-call
(lambda (src proc args) (lambda (src proc args)
(make-struct (vector-ref %expanded-vtables 11) 0 src proc args))) (make-struct/no-tail (vector-ref %expanded-vtables 11) src proc args)))
(make-primcall (make-primcall
(lambda (src name args) (lambda (src name args)
(make-struct (vector-ref %expanded-vtables 12) 0 src name args))) (make-struct/no-tail (vector-ref %expanded-vtables 12) src name args)))
(make-seq (make-seq
(lambda (src head tail) (lambda (src head tail)
(make-struct (vector-ref %expanded-vtables 13) 0 src head tail))) (make-struct/no-tail (vector-ref %expanded-vtables 13) src head tail)))
(make-lambda (make-lambda
(lambda (src meta body) (lambda (src meta body)
(make-struct (vector-ref %expanded-vtables 14) 0 src meta body))) (make-struct/no-tail (vector-ref %expanded-vtables 14) src meta body)))
(make-lambda-case (make-lambda-case
(lambda (src req opt rest kw inits gensyms body alternate) (lambda (src req opt rest kw inits gensyms body alternate)
(make-struct (make-struct/no-tail
(vector-ref %expanded-vtables 15) (vector-ref %expanded-vtables 15)
0
src src
req req
opt opt
@ -80,9 +92,8 @@
alternate))) alternate)))
(make-let (make-let
(lambda (src names gensyms vals body) (lambda (src names gensyms vals body)
(make-struct (make-struct/no-tail
(vector-ref %expanded-vtables 16) (vector-ref %expanded-vtables 16)
0
src src
names names
gensyms gensyms
@ -90,9 +101,8 @@
body))) body)))
(make-letrec (make-letrec
(lambda (src in-order? names gensyms vals body) (lambda (src in-order? names gensyms vals body)
(make-struct (make-struct/no-tail
(vector-ref %expanded-vtables 17) (vector-ref %expanded-vtables 17)
0
src src
in-order? in-order?
names names
@ -241,7 +251,8 @@
(syntax-object? (syntax-object?
(lambda (x) (lambda (x)
(or (syntax? x) (or (syntax? x)
(and (vector? x) (and (allow-legacy-syntax-objects?)
(vector? x)
(= (vector-length x) 4) (= (vector-length x) 4)
(eqv? (vector-ref x 0) 'syntax-object))))) (eqv? (vector-ref x 0) 'syntax-object)))))
(make-syntax-object (make-syntax-object
@ -999,11 +1010,11 @@
(source-wrap e w (cdr w) mod) (source-wrap e w (cdr w) mod)
x)) x))
(else (decorate-source x s)))))) (else (decorate-source x s))))))
(let* ((t-680b775fb37a463-7f9 transformer-environment) (let* ((t-680b775fb37a463-7fa transformer-environment)
(t-680b775fb37a463-7fa (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-7fb (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-7f9
t-680b775fb37a463-7fa t-680b775fb37a463-7fa
t-680b775fb37a463-7fb
(lambda () (lambda ()
(rebuild-macro-output (rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod)) (p (source-wrap e (anti-mark w) s mod))
@ -1539,11 +1550,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-aea (map (lambda (tmp-680b775fb37a463-aeb
tmp-680b775fb37a463-ae9 tmp-680b775fb37a463-aea
tmp-680b775fb37a463-ae8) tmp-680b775fb37a463-ae9)
(cons tmp-680b775fb37a463-ae8 (cons tmp-680b775fb37a463-ae9
(cons tmp-680b775fb37a463-ae9 tmp-680b775fb37a463-aea))) (cons tmp-680b775fb37a463-aea tmp-680b775fb37a463-aeb)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1843,11 +1854,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-cb7 (map (lambda (tmp-680b775fb37a463-cb8
tmp-680b775fb37a463-cb6 tmp-680b775fb37a463-cb7
tmp-680b775fb37a463-cb5) tmp-680b775fb37a463-cb6)
(cons tmp-680b775fb37a463-cb5 (cons tmp-680b775fb37a463-cb6
(cons tmp-680b775fb37a463-cb6 tmp-680b775fb37a463-cb7))) (cons tmp-680b775fb37a463-cb7 tmp-680b775fb37a463-cb8)))
e2 e2
e1 e1
args))) args)))
@ -1859,11 +1870,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-ccd (map (lambda (tmp-680b775fb37a463-cce
tmp-680b775fb37a463-ccc tmp-680b775fb37a463-ccd
tmp-680b775fb37a463-ccb) tmp-680b775fb37a463-ccc)
(cons tmp-680b775fb37a463-ccb (cons tmp-680b775fb37a463-ccc
(cons tmp-680b775fb37a463-ccc tmp-680b775fb37a463-ccd))) (cons tmp-680b775fb37a463-ccd tmp-680b775fb37a463-cce)))
e2 e2
e1 e1
args))) args)))
@ -1886,11 +1897,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-ced (map (lambda (tmp-680b775fb37a463-cee
tmp-680b775fb37a463-cec tmp-680b775fb37a463-ced
tmp-680b775fb37a463-ceb) tmp-680b775fb37a463-cec)
(cons tmp-680b775fb37a463-ceb (cons tmp-680b775fb37a463-cec
(cons tmp-680b775fb37a463-cec tmp-680b775fb37a463-ced))) (cons tmp-680b775fb37a463-ced tmp-680b775fb37a463-cee)))
e2 e2
e1 e1
args))) args)))
@ -1902,11 +1913,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-d03 (map (lambda (tmp-680b775fb37a463-d04
tmp-680b775fb37a463-d02 tmp-680b775fb37a463-d03
tmp-680b775fb37a463-d01) tmp-680b775fb37a463-d02)
(cons tmp-680b775fb37a463-d01 (cons tmp-680b775fb37a463-d02
(cons tmp-680b775fb37a463-d02 tmp-680b775fb37a463-d03))) (cons tmp-680b775fb37a463-d03 tmp-680b775fb37a463-d04)))
e2 e2
e1 e1
args))) args)))
@ -2839,9 +2850,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-116f) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-116f tmp-680b775fb37a463) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-1)) tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -2856,9 +2867,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-118b
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-118a
tmp-680b775fb37a463-118a)) tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-118a)
tmp-680b775fb37a463-118b))
template template
pattern pattern
keyword))) keyword)))
@ -2874,11 +2887,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11a9 (map (lambda (tmp-680b775fb37a463-11aa
tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9
tmp-680b775fb37a463-11a7) tmp-680b775fb37a463-11a8)
(list (cons tmp-680b775fb37a463-11a7 tmp-680b775fb37a463-11a8) (list (cons tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9)
tmp-680b775fb37a463-11a9)) tmp-680b775fb37a463-11aa))
template template
pattern pattern
keyword))) keyword)))
@ -3050,8 +3063,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-121a)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-121a))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3085,8 +3098,7 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-122f) (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
(list "value" tmp-680b775fb37a463-122f))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3196,8 +3208,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-127d) (apply (lambda (t-680b775fb37a463-127e)
(cons "vector" t-680b775fb37a463-127d)) (cons "vector" t-680b775fb37a463-127e))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3207,7 +3219,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) (list "quote" tmp-680b775fb37a463)) (k (map (lambda (tmp-680b775fb37a463-128a)
(list "quote" tmp-680b775fb37a463-128a))
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))))
@ -3232,9 +3245,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-12a7) (apply (lambda (t-680b775fb37a463-12a8)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12a7)) t-680b775fb37a463-12a8))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3250,10 +3263,10 @@
(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-12bb t-680b775fb37a463-12ba) (apply (lambda (t-680b775fb37a463-12bc t-680b775fb37a463-12bb)
(list (make-syntax 'cons '((top)) '(hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12bb t-680b775fb37a463-12bc
t-680b775fb37a463-12ba)) t-680b775fb37a463-12bb))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3266,9 +3279,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-12c7) (apply (lambda (t-680b775fb37a463-12c8)
(cons (make-syntax 'append '((top)) '(hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12c7)) t-680b775fb37a463-12c8))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3281,9 +3294,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-12d3) (apply (lambda (t-680b775fb37a463-12d4)
(cons (make-syntax 'vector '((top)) '(hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12d3)) t-680b775fb37a463-12d4))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3294,9 +3307,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12df tmp)) (let ((t-680b775fb37a463-12e0 tmp))
(list (make-syntax 'list->vector '((top)) '(hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12df)))) t-680b775fb37a463-12e0))))
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

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

@ -184,7 +184,8 @@
(sfields (map (lambda (f) (datum->syntax x f)) fields)) (sfields (map (lambda (f) (datum->syntax x f)) fields))
(ctor (datum->syntax x (symbol-append 'make- stem)))) (ctor (datum->syntax x (symbol-append 'make- stem))))
(cons #`(define (#,ctor #,@sfields) (cons #`(define (#,ctor #,@sfields)
(make-struct (vector-ref %expanded-vtables #,n) 0 (make-struct/no-tail
(vector-ref %expanded-vtables #,n)
#,@sfields)) #,@sfields))
out))) out)))
#`(begin #,@(reverse out)))))))) #`(begin #,@(reverse out))))))))