[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/07: psyntax generates calls to make-struct/no-tail
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/07: psyntax generates calls to make-struct/no-tail |
|
Date: |
Fri, 22 Sep 2017 05:49:33 -0400 (EDT) |
wingo pushed a commit to branch stable-2.2
in repository guile.
commit da9da0eca402a684f4837e8085f2846148ef6ef6
Author: Andy Wingo <address@hidden>
Date: Wed Sep 20 21:55:21 2017 +0200
psyntax generates calls to make-struct/no-tail
* module/ice-9/psyntax.scm (define-expansion-constructors): Expand to
make-struct/no-tail.
* module/ice-9/psyntax-pp.scm: Regenerate.
---
module/ice-9/psyntax-pp.scm | 175 ++++++++++++++++++++++++--------------------
module/ice-9/psyntax.scm | 5 +-
2 files changed, 97 insertions(+), 83 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index d2c5a26..ed967a6 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -8,27 +8,41 @@
(syntax-module (module-ref (current-module) 'syntax-module)))
(letrec*
((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
(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
(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
(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
(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
(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
(lambda (src mod name public? exp)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 6)
- 0
src
mod
name
@@ -36,39 +50,37 @@
exp)))
(make-toplevel-ref
(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
(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
(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
(lambda (src test consequent alternate)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 10)
- 0
src
test
consequent
alternate)))
(make-call
(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
(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
(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
(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
(lambda (src req opt rest kw inits gensyms body alternate)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 15)
- 0
src
req
opt
@@ -80,9 +92,8 @@
alternate)))
(make-let
(lambda (src names gensyms vals body)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 16)
- 0
src
names
gensyms
@@ -90,9 +101,8 @@
body)))
(make-letrec
(lambda (src in-order? names gensyms vals body)
- (make-struct
+ (make-struct/no-tail
(vector-ref %expanded-vtables 17)
- 0
src
in-order?
names
@@ -241,7 +251,8 @@
(syntax-object?
(lambda (x)
(or (syntax? x)
- (and (vector? x)
+ (and (allow-legacy-syntax-objects?)
+ (vector? x)
(= (vector-length x) 4)
(eqv? (vector-ref x 0) 'syntax-object)))))
(make-syntax-object
@@ -999,11 +1010,11 @@
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (let* ((t-680b775fb37a463-7f9 transformer-environment)
- (t-680b775fb37a463-7fa (lambda (k) (k e r w s rib mod))))
+ (let* ((t-680b775fb37a463-7fa transformer-environment)
+ (t-680b775fb37a463-7fb (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-7f9
t-680b775fb37a463-7fa
+ t-680b775fb37a463-7fb
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1539,11 +1550,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-aea
- tmp-680b775fb37a463-ae9
-
tmp-680b775fb37a463-ae8)
- (cons tmp-680b775fb37a463-ae8
- (cons
tmp-680b775fb37a463-ae9 tmp-680b775fb37a463-aea)))
+ (map (lambda (tmp-680b775fb37a463-aeb
+ tmp-680b775fb37a463-aea
+
tmp-680b775fb37a463-ae9)
+ (cons tmp-680b775fb37a463-ae9
+ (cons
tmp-680b775fb37a463-aea tmp-680b775fb37a463-aeb)))
e2*
e1*
args*)))
@@ -1843,11 +1854,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-cb7
- tmp-680b775fb37a463-cb6
- tmp-680b775fb37a463-cb5)
- (cons tmp-680b775fb37a463-cb5
- (cons tmp-680b775fb37a463-cb6
tmp-680b775fb37a463-cb7)))
+ (map (lambda (tmp-680b775fb37a463-cb8
+ tmp-680b775fb37a463-cb7
+ tmp-680b775fb37a463-cb6)
+ (cons tmp-680b775fb37a463-cb6
+ (cons tmp-680b775fb37a463-cb7
tmp-680b775fb37a463-cb8)))
e2
e1
args)))
@@ -1859,11 +1870,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-ccd
- tmp-680b775fb37a463-ccc
- tmp-680b775fb37a463-ccb)
- (cons tmp-680b775fb37a463-ccb
- (cons tmp-680b775fb37a463-ccc
tmp-680b775fb37a463-ccd)))
+ (map (lambda (tmp-680b775fb37a463-cce
+ tmp-680b775fb37a463-ccd
+ tmp-680b775fb37a463-ccc)
+ (cons tmp-680b775fb37a463-ccc
+ (cons tmp-680b775fb37a463-ccd
tmp-680b775fb37a463-cce)))
e2
e1
args)))
@@ -1886,11 +1897,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-ced
- tmp-680b775fb37a463-cec
- tmp-680b775fb37a463-ceb)
- (cons tmp-680b775fb37a463-ceb
- (cons tmp-680b775fb37a463-cec
tmp-680b775fb37a463-ced)))
+ (map (lambda (tmp-680b775fb37a463-cee
+ tmp-680b775fb37a463-ced
+ tmp-680b775fb37a463-cec)
+ (cons tmp-680b775fb37a463-cec
+ (cons tmp-680b775fb37a463-ced
tmp-680b775fb37a463-cee)))
e2
e1
args)))
@@ -1902,11 +1913,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-d03
- tmp-680b775fb37a463-d02
- tmp-680b775fb37a463-d01)
- (cons tmp-680b775fb37a463-d01
- (cons tmp-680b775fb37a463-d02
tmp-680b775fb37a463-d03)))
+ (map (lambda (tmp-680b775fb37a463-d04
+ tmp-680b775fb37a463-d03
+ tmp-680b775fb37a463-d02)
+ (cons tmp-680b775fb37a463-d02
+ (cons tmp-680b775fb37a463-d03
tmp-680b775fb37a463-d04)))
e2
e1
args)))
@@ -2839,9 +2850,9 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-116f)
- (list (cons tmp-680b775fb37a463-116f
tmp-680b775fb37a463)
- tmp-680b775fb37a463-1))
+ (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-2))
template
pattern
keyword)))
@@ -2856,9 +2867,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-118a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-118a))
+ (map (lambda (tmp-680b775fb37a463-118b
+ tmp-680b775fb37a463-118a
+ tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-118a)
+ tmp-680b775fb37a463-118b))
template
pattern
keyword)))
@@ -2874,11 +2887,11 @@
dots
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-11a9
- tmp-680b775fb37a463-11a8
- tmp-680b775fb37a463-11a7)
- (list (cons
tmp-680b775fb37a463-11a7 tmp-680b775fb37a463-11a8)
- tmp-680b775fb37a463-11a9))
+ (map (lambda (tmp-680b775fb37a463-11aa
+ tmp-680b775fb37a463-11a9
+ tmp-680b775fb37a463-11a8)
+ (list (cons
tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9)
+ tmp-680b775fb37a463-11aa))
template
pattern
keyword)))
@@ -3050,8 +3063,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463)
- (list
"value" tmp-680b775fb37a463))
+ (map (lambda
(tmp-680b775fb37a463-121a)
+ (list
"value" tmp-680b775fb37a463-121a))
p)
(quasi q lev))
(quasicons
@@ -3085,8 +3098,7 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-122f)
- (list "value"
tmp-680b775fb37a463-122f))
+ (map (lambda
(tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
p)
(vquasi q lev))
(quasicons
@@ -3196,8 +3208,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-127d)
- (cons "vector"
t-680b775fb37a463-127d))
+ (apply (lambda (t-680b775fb37a463-127e)
+ (cons "vector"
t-680b775fb37a463-127e))
tmp)
(syntax-violation
#f
@@ -3207,7 +3219,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda (tmp-680b775fb37a463)
(list "quote" tmp-680b775fb37a463))
+ (k (map (lambda (tmp-680b775fb37a463-128a)
+ (list "quote"
tmp-680b775fb37a463-128a))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") .
each-any))))
@@ -3232,9 +3245,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12a7)
+ (apply (lambda
(t-680b775fb37a463-12a8)
(cons (make-syntax 'list
'((top)) '(hygiene guile))
-
t-680b775fb37a463-12a7))
+
t-680b775fb37a463-12a8))
tmp)
(syntax-violation
#f
@@ -3250,10 +3263,10 @@
(let ((tmp-1 (list (emit (car x*))
(f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1
'(any any))))
(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))
-
t-680b775fb37a463-12bb
-
t-680b775fb37a463-12ba))
+
t-680b775fb37a463-12bc
+
t-680b775fb37a463-12bb))
tmp)
(syntax-violation
#f
@@ -3266,9 +3279,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12c7)
+ (apply (lambda
(t-680b775fb37a463-12c8)
(cons (make-syntax
'append '((top)) '(hygiene guile))
-
t-680b775fb37a463-12c7))
+
t-680b775fb37a463-12c8))
tmp)
(syntax-violation
#f
@@ -3281,9 +3294,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch
tmp-1 'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-12d3)
+ (apply (lambda
(t-680b775fb37a463-12d4)
(cons
(make-syntax 'vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12d3))
+
t-680b775fb37a463-12d4))
tmp)
(syntax-violation
#f
@@ -3294,9 +3307,9 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let
((t-680b775fb37a463-12df tmp))
+ (let
((t-680b775fb37a463-12e0 tmp))
(list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12df))))
+
t-680b775fb37a463-12e0))))
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 5696c46..ffe37cf 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -184,8 +184,9 @@
(sfields (map (lambda (f) (datum->syntax x f))
fields))
(ctor (datum->syntax x (symbol-append 'make- stem))))
(cons #`(define (#,ctor #,@sfields)
- (make-struct (vector-ref %expanded-vtables #,n) 0
- #,@sfields))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables #,n)
+ #,@sfields))
out)))
#`(begin #,@(reverse out))))))))
- [Guile-commits] branch stable-2.2 updated (ac0d3dc -> c7c7588), Andy Wingo, 2017/09/22
- [Guile-commits] 05/07: Remove unused code in struct.c, Andy Wingo, 2017/09/22
- [Guile-commits] 07/07: Fix up make-struct-layout and make-struct/no-tail docstrings, Andy Wingo, 2017/09/22
- [Guile-commits] 03/07: Remove references to tail arrays in the documentation, Andy Wingo, 2017/09/22
- [Guile-commits] 01/07: psyntax generates calls to make-struct/no-tail,
Andy Wingo <=
- [Guile-commits] 02/07: Use make-struct/no-tail instead of make-struct, Andy Wingo, 2017/09/22
- [Guile-commits] 06/07: Deprecate struct "self" slots, Andy Wingo, 2017/09/22
- [Guile-commits] 04/07: Deprecate make-struct, Andy Wingo, 2017/09/22