[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/04: Remove support for legacy syntax objects.
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 03/04: Remove support for legacy syntax objects. |
|
Date: |
Mon, 22 May 2017 11:35:54 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 1f560bc4b7d1116d678c82f781b2c9259d20c59d
Author: Andy Wingo <address@hidden>
Date: Mon May 22 15:36:28 2017 +0200
Remove support for legacy syntax objects.
* module/ice-9/psyntax.scm: Remove support for legacy syntax objects.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/deprecated.scm (allow-legacy-syntax-objects?): New
deprecation.
* module/ice-9/boot-9.scm: Don't define allow-legacy-syntax-objects?.
* doc/ref/api-macros.texi: Remove documentation for
allow-legacy-syntax-objects?.
---
doc/ref/api-macros.texi | 38 -----
module/ice-9/boot-9.scm | 7 -
module/ice-9/deprecated.scm | 15 ++
module/ice-9/psyntax-pp.scm | 351 +++++++++++++++++++-------------------------
module/ice-9/psyntax.scm | 247 ++++++++++++++-----------------
5 files changed, 282 insertions(+), 376 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 7fa62e3..ef06214 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -791,44 +791,6 @@ Return the source properties that correspond to the syntax
object
@var{x}. @xref{Source Properties}, for more information.
@end deffn
-And now, a bit of confession time. Guile's syntax expander originates
-in code from Chez Scheme: a version of the expander in Chez Scheme that
-was made portable to other Scheme systems. Way back in the mid-1990s,
-some Scheme systems didn't even have the ability to define new abstract
-data types. For this reason, the portable expander from Chez Scheme
-that Guile inherited used tagged vectors as syntax objects: vectors
-whose first element was the symbol, @code{syntax-object}.
-
-At the time of this writing it is 2017 and Guile still has support for
-this strategy. It worked for this long because no one ever puts a
-literal vector in the operator position:
-
address@hidden
-(#(syntax-object ...) 1 2 3)
address@hidden example
-
-But this state of affairs was an error. Because syntax objects are just
-vectors, this makes it possible for any Scheme code to forge a syntax
-object which might cause it to violate abstraction boundaries. You
-can't build a sandboxing facility that limits the set of bindings in
-scope when one can always escape that limit just by evaluating a special
-vector. To fix this problem, Guile 2.2.1 finally migrated to represent
-syntax objects as a distinct type with a distinct constructor that is
-unavailable to user code.
-
-However, Guile still has to support ``legacy'' syntax objects, because
-it could be that a file compiled with Guile 2.2.0 embeds syntax objects
-of the vector kind. Whether the expander treats the special tagged
-vectors as syntax objects is now controllable by the
address@hidden parameter:
-
address@hidden {Scheme Procedure} allow-legacy-syntax-objects?
-A parameter that indicates whether the expander should support legacy
-syntax objects, as described above. For ABI stability reasons, the
-default is @code{#t}. Use @code{parameterize} to bind it to @code{#f}.
address@hidden
address@hidden deffn
-
Guile also offers some more experimental interfaces in a separate
module. As was the case with the Large Hadron Collider, it is unclear
to our senior macrologists whether adding these interfaces will result
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a70cd11..5af2950 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -299,9 +299,6 @@ This is handy for tracing function calls, e.g.:
(define (absolute-file-name? file-name) #t)
(define (open-input-file str) (open-file str "r"))
-;; Temporary definition; replaced by a parameter later.
-(define (allow-legacy-syntax-objects?) #f)
-
;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
@@ -1431,10 +1428,6 @@ CONV is not applied to the initial value."
(set! default-prompt-tag (make-parameter (default-prompt-tag)))
-;; Because code compiled with Guile 2.2.0 embeds legacy syntax objects
-;; into its compiled macros, we have to default to true, sadly.
-(set! allow-legacy-syntax-objects? (make-parameter #t))
-
;;; {Languages}
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 597ca8b..85be82e 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -16,3 +16,18 @@
;;;;
(define-module (ice-9 deprecated))
+
+(define-syntax-rule (define-deprecated name message exp)
+ (begin
+ (define-syntax rule
+ (identifier-syntax
+ (begin
+ (issue-deprecation-warning message)
+ exp)))
+ (export rule)))
+
+(define %allow-legacy-syntax-objects? (make-parameter #f))
+(define-deprecated allow-legacy-syntax-objects?
+ "allow-legacy-syntax-objects? is deprecated and has no effect. Guile
+3.0 has no legacy syntax objects."
+ %allow-legacy-syntax-objects?)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index d2c5a26..e2ebece 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -238,28 +238,9 @@
(begin
(for-each maybe-name-value! ids val-exps)
(make-letrec src in-order? ids vars val-exps body-exp)))))
- (syntax-object?
- (lambda (x)
- (or (syntax? x)
- (and (vector? x)
- (= (vector-length x) 4)
- (eqv? (vector-ref x 0) 'syntax-object)))))
- (make-syntax-object
- (lambda (expression wrap module)
- (make-syntax expression wrap module)))
- (syntax-object-expression
- (lambda (obj)
- (if (syntax? obj) (syntax-expression obj) (vector-ref obj 1))))
- (syntax-object-wrap
- (lambda (obj)
- (if (syntax? obj) (syntax-wrap obj) (vector-ref obj 2))))
- (syntax-object-module
- (lambda (obj)
- (if (syntax? obj) (syntax-module obj) (vector-ref obj 3))))
(source-annotation
(lambda (x)
- (let ((props (source-properties
- (if (syntax-object? x) (syntax-object-expression x)
x))))
+ (let ((props (source-properties (if (syntax? x) (syntax-expression x)
x))))
(and (pair? props) props))))
(extend-env
(lambda (labels bindings r)
@@ -288,18 +269,15 @@
(global-extend
(lambda (type sym val) (put-global-definition-hook sym type val)))
(nonsymbol-id?
- (lambda (x)
- (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
+ (lambda (x) (and (syntax? x) (symbol? (syntax-expression x)))))
(id? (lambda (x)
- (if (symbol? x)
- #t
- (and (syntax-object? x) (symbol? (syntax-object-expression
x))))))
+ (if (symbol? x) #t (and (syntax? x) (symbol? (syntax-expression
x))))))
(id-sym-name&marks
(lambda (x w)
- (if (syntax-object? x)
+ (if (syntax? x)
(values
- (syntax-object-expression x)
- (join-marks (car w) (car (syntax-object-wrap x))))
+ (syntax-expression x)
+ (join-marks (car w) (car (syntax-wrap x))))
(values x (car w)))))
(gen-label (lambda () (symbol->string (module-gensym "l"))))
(gen-labels
@@ -325,10 +303,10 @@
(lambda (ribcage id label)
(set-ribcage-symnames!
ribcage
- (cons (syntax-object-expression id) (ribcage-symnames ribcage)))
+ (cons (syntax-expression id) (ribcage-symnames ribcage)))
(set-ribcage-marks!
ribcage
- (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage)))
+ (cons (car (syntax-wrap id)) (ribcage-marks ribcage)))
(set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
(make-binding-wrap
(lambda (ids labels w)
@@ -402,10 +380,10 @@
(values n marks))))
(else (f (+ i 1)))))))))
(cond ((symbol? id) (or (search id (cdr w) (car w) mod) id))
- ((syntax-object? id)
- (let ((id (syntax-object-expression id))
- (w1 (syntax-object-wrap id))
- (mod (syntax-object-module id)))
+ ((syntax? id)
+ (let ((id (syntax-expression id))
+ (w1 (syntax-wrap id))
+ (mod (syntax-module id)))
(let ((marks (join-marks (car w) (car w1))))
(call-with-values
(lambda () (search id (cdr w) marks mod))
@@ -466,23 +444,19 @@
(or (assq-ref r label) '(displaced-lexical)))))
(values (car b) (cdr b) mod)))))
(let ((n (id-var-name id w mod)))
- (cond ((syntax-object? n)
+ (cond ((syntax? n)
(if (not (eq? n id))
(resolve-identifier n w r mod resolve-syntax-parameters?)
(resolve-identifier
- (syntax-object-expression n)
- (syntax-object-wrap n)
+ (syntax-expression n)
+ (syntax-wrap n)
r
- (syntax-object-module n)
+ (syntax-module n)
resolve-syntax-parameters?)))
((symbol? n)
- (resolve-global
- n
- (if (syntax-object? id) (syntax-object-module id) mod)))
+ (resolve-global n (if (syntax? id) (syntax-module id)
mod)))
((string? n)
- (resolve-lexical
- n
- (if (syntax-object? id) (syntax-object-module id) mod)))
+ (resolve-lexical n (if (syntax? id) (syntax-module id)
mod)))
(else (error "unexpected id-var-name" id w n)))))))
(transformer-environment
(make-fluid
@@ -492,8 +466,8 @@
(lambda (k) ((fluid-ref transformer-environment) k)))
(free-id=?
(lambda (i j)
- (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
- (mj (and (syntax-object? j) (syntax-object-module j)))
+ (let* ((mi (and (syntax? i) (syntax-module i)))
+ (mj (and (syntax? j) (syntax-module j)))
(ni (id-var-name i '(()) mi))
(nj (id-var-name j '(()) mj)))
(letrec*
@@ -501,12 +475,11 @@
(lambda (id mod)
(module-variable
(if mod (resolve-module (cdr mod)) (current-module))
- (let ((x id)) (if (syntax-object? x)
(syntax-object-expression x) x))))))
- (cond ((syntax-object? ni) (free-id=? ni j))
- ((syntax-object? nj) (free-id=? i nj))
+ (let ((x id)) (if (syntax? x) (syntax-expression x) x))))))
+ (cond ((syntax? ni) (free-id=? ni j))
+ ((syntax? nj) (free-id=? i nj))
((symbol? ni)
- (and (eq? nj
- (let ((x j)) (if (syntax-object? x)
(syntax-object-expression x) x)))
+ (and (eq? nj (let ((x j)) (if (syntax? x)
(syntax-expression x) x)))
(let ((bi (id-module-binding i mi)))
(if bi
(eq? bi (id-module-binding j mj))
@@ -515,11 +488,9 @@
(else (equal? ni nj)))))))
(bound-id=?
(lambda (i j)
- (if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (syntax-object-expression i) (syntax-object-expression j))
- (same-marks?
- (car (syntax-object-wrap i))
- (car (syntax-object-wrap j))))
+ (if (and (syntax? i) (syntax? j))
+ (and (eq? (syntax-expression i) (syntax-expression j))
+ (same-marks? (car (syntax-wrap i)) (car (syntax-wrap j))))
(eq? i j))))
(valid-bound-ids?
(lambda (ids)
@@ -538,13 +509,13 @@
(or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
(wrap (lambda (x w defmod)
(cond ((and (null? (car w)) (null? (cdr w))) x)
- ((syntax-object? x)
- (make-syntax-object
- (syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))
- (syntax-object-module x)))
+ ((syntax? x)
+ (make-syntax
+ (syntax-expression x)
+ (join-wraps w (syntax-wrap x))
+ (syntax-module x)))
((null? x) x)
- (else (make-syntax-object x w defmod)))))
+ (else (make-syntax x w defmod)))))
(source-wrap
(lambda (x w s defmod) (wrap (decorate-source x s) w defmod)))
(expand-sequence
@@ -568,13 +539,13 @@
(extend-ribcage!
ribcage
id
- (cons (syntax-object-module id) (wrap var '((top))
mod))))))
+ (cons (syntax-module id) (wrap var '((top)) mod))))))
(macro-introduced-identifier?
- (lambda (id) (not (equal? (car (syntax-object-wrap id))
'(top)))))
+ (lambda (id) (not (equal? (car (syntax-wrap id)) '(top)))))
(fresh-derived-name
(lambda (id orig-form)
(symbol-append
- (syntax-object-expression id)
+ (syntax-expression id)
'-
(string->symbol
(number->string
@@ -605,7 +576,7 @@
(label (gen-label))
(var (if (macro-introduced-identifier?
id)
(fresh-derived-name id x)
- (syntax-object-expression id))))
+ (syntax-expression id))))
(record-definition! id var)
(list (if (eq? m 'c&e)
(let ((x (build-global-definition s
var (expand e r w mod))))
@@ -624,7 +595,7 @@
(label (gen-label))
(var (if (macro-introduced-identifier?
id)
(fresh-derived-name id x)
- (syntax-object-expression id))))
+ (syntax-expression id))))
(record-definition! id var)
(let ((key m))
(cond ((memv key '(c))
@@ -757,7 +728,7 @@
((memv key '(global))
(if (equal? fmod '(primitive))
(values 'primitive-call fval e e w s mod)
- (values 'global-call (make-syntax-object fval
w fmod) e e w s mod)))
+ (values 'global-call (make-syntax fval w
fmod) e e w s mod)))
((memv key '(macro))
(syntax-type
(expand-macro fval e r w s rib mod)
@@ -835,14 +806,14 @@
"source expression failed to match any
pattern"
tmp-1))))
(else (values 'call #f e e w s mod))))))))
- ((syntax-object? e)
+ ((syntax? e)
(syntax-type
- (syntax-object-expression e)
+ (syntax-expression e)
r
- (join-wraps w (syntax-object-wrap e))
+ (join-wraps w (syntax-wrap e))
(or (source-annotation e) s)
rib
- (or (syntax-object-module e) mod)
+ (or (syntax-module e) mod)
for-car?))
((self-evaluating? e) (values 'constant #f e e w s mod))
(else (values 'other #f e e w s mod)))))
@@ -867,7 +838,7 @@
(build-lexical-reference
'fun
(source-annotation id)
- (if (syntax-object? id) (syntax->datum id) id)
+ (if (syntax? id) (syntax->datum id) id)
value))
e
r
@@ -878,8 +849,8 @@
(expand-call
(build-global-reference
(source-annotation (car e))
- (if (syntax-object? value) (syntax-object-expression
value) value)
- (if (syntax-object? value) (syntax-object-module value)
mod))
+ (if (syntax? value) (syntax-expression value) value)
+ (if (syntax? value) (syntax-module value) mod))
e
r
w
@@ -971,19 +942,19 @@
(cons (rebuild-macro-output (car x) m)
(rebuild-macro-output (cdr x) m))
s))
- ((syntax-object? x)
- (let ((w (syntax-object-wrap x)))
+ ((syntax? x)
+ (let ((w (syntax-wrap x)))
(let ((ms (car w)) (ss (cdr w)))
(if (and (pair? ms) (eq? (car ms) #f))
- (make-syntax-object
- (syntax-object-expression x)
+ (make-syntax
+ (syntax-expression x)
(cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr
ss)))
- (syntax-object-module x))
- (make-syntax-object
- (decorate-source (syntax-object-expression x) s)
+ (syntax-module x))
+ (make-syntax
+ (decorate-source (syntax-expression x) s)
(cons (cons m ms)
(if rib (cons rib (cons 'shift ss)) (cons
'shift ss)))
- (syntax-object-module x))))))
+ (syntax-module x))))))
((vector? x)
(let* ((n (vector-length x)) (v (decorate-source
(make-vector n) s)))
(let loop ((i 0))
@@ -999,11 +970,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-7da transformer-environment)
+ (t-680b775fb37a463-7db (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-7f9
- t-680b775fb37a463-7fa
+ t-680b775fb37a463-7da
+ t-680b775fb37a463-7db
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1163,10 +1134,7 @@
(call-with-values
(lambda ()
(resolve-identifier
- (make-syntax-object
- '#{ $sc-ellipsis }#
- (syntax-object-wrap e)
- (syntax-object-module e))
+ (make-syntax '#{ $sc-ellipsis }# (syntax-wrap e)
(syntax-module e))
'(())
r
mod
@@ -1539,11 +1507,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-acb
+ tmp-680b775fb37a463-aca
+
tmp-680b775fb37a463-ac9)
+ (cons tmp-680b775fb37a463-ac9
+ (cons
tmp-680b775fb37a463-aca tmp-680b775fb37a463-acb)))
e2*
e1*
args*)))
@@ -1560,8 +1528,7 @@
(if (memq 'top (car w))
x
(let f ((x x))
- (cond ((syntax-object? x)
- (strip (syntax-object-expression x)
(syntax-object-wrap x)))
+ (cond ((syntax? x) (strip (syntax-expression x) (syntax-wrap
x)))
((pair? x)
(let ((a (f (car x))) (d (f (cdr x))))
(if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a
d))))
@@ -1574,7 +1541,7 @@
(else x))))))
(gen-var
(lambda (id)
- (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (let ((id (if (syntax? id) (syntax-expression id) id)))
(module-gensym (symbol->string id)))))
(lambda-var-list
(lambda (vars)
@@ -1582,10 +1549,8 @@
(cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f)
ls) w))
((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls)
- ((syntax-object? vars)
- (lvl (syntax-object-expression vars)
- ls
- (join-wraps w (syntax-object-wrap vars))))
+ ((syntax? vars)
+ (lvl (syntax-expression vars) ls (join-wraps w (syntax-wrap
vars))))
(else (cons vars ls)))))))
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
@@ -1843,11 +1808,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-c98
+ tmp-680b775fb37a463-c97
+ tmp-680b775fb37a463-c96)
+ (cons tmp-680b775fb37a463-c96
+ (cons tmp-680b775fb37a463-c97
tmp-680b775fb37a463-c98)))
e2
e1
args)))
@@ -1859,11 +1824,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-cae
+ tmp-680b775fb37a463-cad
+ tmp-680b775fb37a463-cac)
+ (cons tmp-680b775fb37a463-cac
+ (cons tmp-680b775fb37a463-cad
tmp-680b775fb37a463-cae)))
e2
e1
args)))
@@ -1886,11 +1851,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-cce
+ tmp-680b775fb37a463-ccd
+ tmp-680b775fb37a463-ccc)
+ (cons tmp-680b775fb37a463-ccc
+ (cons tmp-680b775fb37a463-ccd
tmp-680b775fb37a463-cce)))
e2
e1
args)))
@@ -1902,11 +1867,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-ce4
+ tmp-680b775fb37a463-ce3
+ tmp-680b775fb37a463-ce2)
+ (cons tmp-680b775fb37a463-ce2
+ (cons tmp-680b775fb37a463-ce3
tmp-680b775fb37a463-ce4)))
e2
e1
args)))
@@ -1921,10 +1886,10 @@
(apply (lambda (dots e1 e2)
(let ((id (if (symbol? dots)
'#{ $sc-ellipsis }#
- (make-syntax-object
+ (make-syntax
'#{ $sc-ellipsis }#
- (syntax-object-wrap dots)
- (syntax-object-module dots)))))
+ (syntax-wrap dots)
+ (syntax-module dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (cons 'ellipsis (source-wrap dots
w s mod)))))
@@ -2102,10 +2067,10 @@
((remodulate
(lambda (x mod)
(cond ((pair? x) (cons (remodulate (car x) mod) (remodulate
(cdr x) mod)))
- ((syntax-object? x)
- (make-syntax-object
- (remodulate (syntax-object-expression x) mod)
- (syntax-object-wrap x)
+ ((syntax? x)
+ (make-syntax
+ (remodulate (syntax-expression x) mod)
+ (syntax-wrap x)
mod))
((vector? x)
(let* ((n (vector-length x)) (v (make-vector n)))
@@ -2125,9 +2090,7 @@
(if (and tmp-1
(apply (lambda (id)
(and (id? id)
- (equal?
- (cdr (if (syntax-object? id)
(syntax-object-module id) mod))
- '(guile))))
+ (equal? (cdr (if (syntax? id)
(syntax-module id) mod)) '(guile))))
tmp-1))
(apply (lambda (id) (values (syntax->datum id) r '((top)) #f
'(primitive)))
tmp-1)
@@ -2405,10 +2368,7 @@
(set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax
(lambda (id datum)
- (make-syntax-object
- datum
- (syntax-object-wrap id)
- (syntax-object-module id))))
+ (make-syntax datum (syntax-wrap id) (syntax-module id))))
(set! syntax->datum (lambda (x) (strip x '(()))))
(set! syntax-source (lambda (x) (source-annotation x)))
(set! generate-temporaries
@@ -2456,7 +2416,7 @@
(let ((x id))
(if (not (nonsymbol-id? x))
(syntax-violation 'syntax-module "invalid argument" x)))
- (let ((mod (syntax-object-module id)))
+ (let ((mod (syntax-module id)))
(and (not (equal? mod '(primitive))) (cdr mod)))))
(syntax-local-binding
(lambda* (id
@@ -2477,10 +2437,10 @@
(call-with-values
(lambda ()
(resolve-identifier
- (syntax-object-expression id)
- (strip-anti-mark (syntax-object-wrap id))
+ (syntax-expression id)
+ (strip-anti-mark (syntax-wrap id))
r
- (syntax-object-module id)
+ (syntax-module id)
resolve-syntax-parameters?))
(lambda (type value mod)
(let ((key type))
@@ -2497,10 +2457,10 @@
((memv key '(ellipsis))
(values
'ellipsis
- (make-syntax-object
- (syntax-object-expression value)
- (anti-mark (syntax-object-wrap value))
- (syntax-object-module value))))
+ (make-syntax
+ (syntax-expression value)
+ (anti-mark (syntax-wrap value))
+ (syntax-module value))))
(else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers
(lambda (id)
@@ -2510,9 +2470,7 @@
'syntax-locally-bound-identifiers
"invalid argument"
x)))
- (locally-bound-identifiers
- (syntax-object-wrap id)
- (syntax-object-module id)))))
+ (locally-bound-identifiers (syntax-wrap id) (syntax-module id)))))
(define! '%syntax-module %syntax-module)
(define! 'syntax-local-binding syntax-local-binding)
(define!
@@ -2527,12 +2485,12 @@
(let ((rest (match-each (cdr e) p w mod)))
(and rest (cons first rest))))))
((null? e) '())
- ((syntax-object? e)
+ ((syntax? e)
(match-each
- (syntax-object-expression e)
+ (syntax-expression e)
p
- (join-wraps w (syntax-object-wrap e))
- (syntax-object-module e)))
+ (join-wraps w (syntax-wrap e))
+ (syntax-module e)))
(else #f))))
(match-each+
(lambda (e x-pat y-pat z-pat w r mod)
@@ -2547,9 +2505,8 @@
(if xr (values (cons xr xr*) y-pat r) (values #f
#f #f)))
(values '() (cdr y-pat) (match (car e) (car y-pat)
w r mod)))
(values #f #f #f)))))
- ((syntax-object? e)
- (f (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
+ ((syntax? e)
+ (f (syntax-expression e) (join-wraps w (syntax-wrap e))))
(else (values '() y-pat (match e z-pat w r mod)))))))
(match-each-any
(lambda (e w mod)
@@ -2557,10 +2514,10 @@
(let ((l (match-each-any (cdr e) w mod)))
(and l (cons (wrap (car e) w mod) l))))
((null? e) '())
- ((syntax-object? e)
+ ((syntax? e)
(match-each-any
- (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))
+ (syntax-expression e)
+ (join-wraps w (syntax-wrap e))
mod))
(else #f))))
(match-empty
@@ -2625,25 +2582,25 @@
(cond ((not r) #f)
((eq? p '_) r)
((eq? p 'any) (cons (wrap e w mod) r))
- ((syntax-object? e)
+ ((syntax? e)
(match*
- (syntax-object-expression e)
+ (syntax-expression e)
p
- (join-wraps w (syntax-object-wrap e))
+ (join-wraps w (syntax-wrap e))
r
- (syntax-object-module e)))
+ (syntax-module e)))
(else (match* e p w r mod))))))
(set! $sc-dispatch
(lambda (e p)
(cond ((eq? p 'any) (list e))
((eq? p '_) '())
- ((syntax-object? e)
+ ((syntax? e)
(match*
- (syntax-object-expression e)
+ (syntax-expression e)
p
- (syntax-object-wrap e)
+ (syntax-wrap e)
'()
- (syntax-object-module e)))
+ (syntax-module e)))
(else (match* e p '(()) '() #f))))))))
(define with-syntax
@@ -2839,9 +2796,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 +2813,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-116b
+ tmp-680b775fb37a463-116a
+ tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-116a)
+ tmp-680b775fb37a463-116b))
template
pattern
keyword)))
@@ -2874,11 +2833,9 @@
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-118a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
+ tmp-680b775fb37a463-118a))
template
pattern
keyword)))
@@ -3026,8 +2983,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463)
- (list
"value" tmp-680b775fb37a463))
+ (map (lambda
(tmp-680b775fb37a463-11f5)
+ (list
"value" tmp-680b775fb37a463-11f5))
p)
(quasi q lev))
(quasicons
@@ -3050,8 +3007,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463)
- (list
"value" tmp-680b775fb37a463))
+ (map (lambda
(tmp-680b775fb37a463-11fa)
+ (list
"value" tmp-680b775fb37a463-11fa))
p)
(quasi q lev))
(quasicons
@@ -3085,8 +3042,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 +3152,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-125e)
+ (cons "vector"
t-680b775fb37a463-125e))
tmp)
(syntax-violation
#f
@@ -3207,7 +3163,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-126a)
+ (list "quote"
tmp-680b775fb37a463-126a))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") .
each-any))))
@@ -3232,9 +3189,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)
(cons (make-syntax 'list
'((top)) '(hygiene guile))
-
t-680b775fb37a463-12a7))
+ t-680b775fb37a463))
tmp)
(syntax-violation
#f
@@ -3250,10 +3207,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-129c t-680b775fb37a463-129b)
(list (make-syntax
'cons '((top)) '(hygiene guile))
-
t-680b775fb37a463-12bb
-
t-680b775fb37a463-12ba))
+
t-680b775fb37a463-129c
+
t-680b775fb37a463-129b))
tmp)
(syntax-violation
#f
@@ -3266,9 +3223,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-12a8)
(cons (make-syntax
'append '((top)) '(hygiene guile))
-
t-680b775fb37a463-12c7))
+
t-680b775fb37a463-12a8))
tmp)
(syntax-violation
#f
@@ -3281,9 +3238,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-12b4)
(cons
(make-syntax 'vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12d3))
+
t-680b775fb37a463-12b4))
tmp)
(syntax-violation
#f
@@ -3294,9 +3251,9 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let
((t-680b775fb37a463-12df tmp))
+ (let
((t-680b775fb37a463-12c0 tmp))
(list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-12df))))
+
t-680b775fb37a463-12c0))))
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..08b3dae 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,7 +1,7 @@
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
-;;;; 2012, 2013, 2015, 2016 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2017
+;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -155,8 +155,8 @@
;;; Bootstrapping:
-;;; When changing syntax-object representations, it is necessary to support
-;;; both old and new syntax-object representations in id-var-name. It
+;;; When changing syntax representations, it is necessary to support
+;;; both old and new syntax representations in id-var-name. It
;;; should be sufficient to recognize old representations and treat
;;; them as not lexically bound.
@@ -471,34 +471,13 @@
;; 'gensym' so that the generated identifier is reproducible.
(module-gensym (symbol->string id)))
- (define (syntax-object? x)
- (or (syntax? x)
- (and (allow-legacy-syntax-objects?)
- (vector? x)
- (= (vector-length x) 4)
- (eqv? (vector-ref x 0) 'syntax-object))))
- (define (make-syntax-object expression wrap module)
- (make-syntax expression wrap module))
- (define (syntax-object-expression obj)
- (if (syntax? obj)
- (syntax-expression obj)
- (vector-ref obj 1)))
- (define (syntax-object-wrap obj)
- (if (syntax? obj)
- (syntax-wrap obj)
- (vector-ref obj 2)))
- (define (syntax-object-module obj)
- (if (syntax? obj)
- (syntax-module obj)
- (vector-ref obj 3)))
-
(define-syntax no-source (identifier-syntax #f))
(define source-annotation
(lambda (x)
(let ((props (source-properties
- (if (syntax-object? x)
- (syntax-object-expression x)
+ (if (syntax? x)
+ (syntax-expression x)
x))))
(and (pair? props) props))))
@@ -619,28 +598,28 @@
(define nonsymbol-id?
(lambda (x)
- (and (syntax-object? x)
- (symbol? (syntax-object-expression x)))))
+ (and (syntax? x)
+ (symbol? (syntax-expression x)))))
(define id?
(lambda (x)
(cond
((symbol? x) #t)
- ((syntax-object? x) (symbol? (syntax-object-expression x)))
+ ((syntax? x) (symbol? (syntax-expression x)))
(else #f))))
(define-syntax-rule (id-sym-name e)
(let ((x e))
- (if (syntax-object? x)
- (syntax-object-expression x)
+ (if (syntax? x)
+ (syntax-expression x)
x)))
(define id-sym-name&marks
(lambda (x w)
- (if (syntax-object? x)
+ (if (syntax? x)
(values
- (syntax-object-expression x)
- (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (syntax-expression x)
+ (join-marks (wrap-marks w) (wrap-marks (syntax-wrap x))))
(values x (wrap-marks w)))))
;; syntax object wraps
@@ -697,10 +676,10 @@
;; must receive ids with complete wraps
(lambda (ribcage id label)
(set-ribcage-symnames! ribcage
- (cons (syntax-object-expression id)
+ (cons (syntax-expression id)
(ribcage-symnames ribcage)))
(set-ribcage-marks! ribcage
- (cons (wrap-marks (syntax-object-wrap id))
+ (cons (wrap-marks (syntax-wrap id))
(ribcage-marks ribcage)))
(set-ribcage-labels! ribcage
(cons label (ribcage-labels ribcage)))))
@@ -830,10 +809,10 @@
(cond
((symbol? id)
(or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
- ((syntax-object? id)
- (let ((id (syntax-object-expression id))
- (w1 (syntax-object-wrap id))
- (mod (syntax-object-module id)))
+ ((syntax? id)
+ (let ((id (syntax-expression id))
+ (w1 (syntax-wrap id))
+ (mod (syntax-module id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
(call-with-values (lambda () (search id (wrap-subst w) marks
mod))
(lambda (new-id marks)
@@ -914,7 +893,7 @@
(values (binding-type b) (binding-value b) mod)))
(let ((n (id-var-name id w mod)))
(cond
- ((syntax-object? n)
+ ((syntax? n)
(cond
((not (eq? n id))
;; This identifier aliased another; recurse to allow
@@ -924,18 +903,18 @@
(else
;; Resolved to a free variable that was introduced by this
;; macro; continue to resolve this global by name.
- (resolve-identifier (syntax-object-expression n)
- (syntax-object-wrap n)
+ (resolve-identifier (syntax-expression n)
+ (syntax-wrap n)
r
- (syntax-object-module n)
+ (syntax-module n)
resolve-syntax-parameters?))))
((symbol? n)
- (resolve-global n (if (syntax-object? id)
- (syntax-object-module id)
+ (resolve-global n (if (syntax? id)
+ (syntax-module id)
mod)))
((string? n)
- (resolve-lexical n (if (syntax-object? id)
- (syntax-object-module id)
+ (resolve-lexical n (if (syntax? id)
+ (syntax-module id)
mod)))
(else
(error "unexpected id-var-name" id w n)))))
@@ -953,8 +932,8 @@
(define free-id=?
(lambda (i j)
- (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
- (mj (and (syntax-object? j) (syntax-object-module j)))
+ (let* ((mi (and (syntax? i) (syntax-module i)))
+ (mj (and (syntax? j) (syntax-module j)))
(ni (id-var-name i empty-wrap mi))
(nj (id-var-name j empty-wrap mj)))
(define (id-module-binding id mod)
@@ -967,8 +946,8 @@
(current-module))
(id-sym-name id)))
(cond
- ((syntax-object? ni) (free-id=? ni j))
- ((syntax-object? nj) (free-id=? i nj))
+ ((syntax? ni) (free-id=? ni j))
+ ((syntax? nj) (free-id=? i nj))
((symbol? ni)
;; `i' is not lexically bound. Assert that `j' is free,
;; and if so, compare their bindings, that they are either
@@ -992,11 +971,11 @@
(define bound-id=?
(lambda (i j)
- (if (and (syntax-object? i) (syntax-object? j))
- (and (eq? (syntax-object-expression i)
- (syntax-object-expression j))
- (same-marks? (wrap-marks (syntax-object-wrap i))
- (wrap-marks (syntax-object-wrap j))))
+ (if (and (syntax? i) (syntax? j))
+ (and (eq? (syntax-expression i)
+ (syntax-expression j))
+ (same-marks? (wrap-marks (syntax-wrap i))
+ (wrap-marks (syntax-wrap j))))
(eq? i j))))
;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
@@ -1037,13 +1016,13 @@
(lambda (x w defmod)
(cond
((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
- ((syntax-object? x)
- (make-syntax-object
- (syntax-object-expression x)
- (join-wraps w (syntax-object-wrap x))
- (syntax-object-module x)))
+ ((syntax? x)
+ (make-syntax
+ (syntax-expression x)
+ (join-wraps w (syntax-wrap x))
+ (syntax-module x)))
((null? x) x)
- (else (make-syntax-object x w defmod)))))
+ (else (make-syntax x w defmod)))))
(define source-wrap
(lambda (x w s defmod)
@@ -1088,13 +1067,13 @@
;; the special case of names that are pairs. See the
;; comments in id-var-name for more.
(extend-ribcage! ribcage id
- (cons (syntax-object-module id)
+ (cons (syntax-module id)
(wrap var top-wrap mod)))))
(define (macro-introduced-identifier? id)
- (not (equal? (wrap-marks (syntax-object-wrap id)) '(top))))
+ (not (equal? (wrap-marks (syntax-wrap id)) '(top))))
(define (fresh-derived-name id orig-form)
(symbol-append
- (syntax-object-expression id)
+ (syntax-expression id)
'-
(string->symbol
;; FIXME: `hash' currently stops descending into nested
@@ -1131,7 +1110,7 @@
(label (gen-label))
(var (if (macro-introduced-identifier? id)
(fresh-derived-name id x)
- (syntax-object-expression id))))
+ (syntax-expression id))))
(record-definition! id var)
(list
(if (eq? m 'c&e)
@@ -1154,7 +1133,7 @@
(label (gen-label))
(var (if (macro-introduced-identifier? id)
(fresh-derived-name id x)
- (syntax-object-expression id))))
+ (syntax-expression id))))
(record-definition! id var)
(case m
((c)
@@ -1341,7 +1320,7 @@
;; need to make sure the fmod information is
;; propagated back correctly -- hence this
;; consing.
- (values 'global-call (make-syntax-object fval w fmod)
+ (values 'global-call (make-syntax fval w fmod)
e e w s mod)))
((macro)
(syntax-type (expand-macro fval e r w s rib mod)
@@ -1391,12 +1370,12 @@
(values 'define-syntax-parameter-form #'name e #'val w s
mod))))
(else
(values 'call #f e e w s mod)))))))
- ((syntax-object? e)
- (syntax-type (syntax-object-expression e)
+ ((syntax? e)
+ (syntax-type (syntax-expression e)
r
- (join-wraps w (syntax-object-wrap e))
+ (join-wraps w (syntax-wrap e))
(or (source-annotation e) s) rib
- (or (syntax-object-module e) mod) for-car?))
+ (or (syntax-module e) mod) for-car?))
((self-evaluating? e) (values 'constant #f e e w s mod))
(else (values 'other #f e e w s mod)))))
@@ -1423,7 +1402,7 @@
(expand-call
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
- (if (syntax-object? id)
+ (if (syntax? id)
(syntax->datum id)
id)
value))
@@ -1431,11 +1410,11 @@
((global-call)
(expand-call
(build-global-reference (source-annotation (car e))
- (if (syntax-object? value)
- (syntax-object-expression value)
+ (if (syntax? value)
+ (syntax-expression value)
value)
- (if (syntax-object? value)
- (syntax-object-module value)
+ (if (syntax? value)
+ (syntax-module value)
mod))
e r w s mod))
((primitive-call)
@@ -1524,23 +1503,23 @@
(cons (rebuild-macro-output (car x) m)
(rebuild-macro-output (cdr x) m))
s))
- ((syntax-object? x)
- (let ((w (syntax-object-wrap x)))
+ ((syntax? x)
+ (let ((w (syntax-wrap x)))
(let ((ms (wrap-marks w)) (ss (wrap-subst w)))
(if (and (pair? ms) (eq? (car ms) the-anti-mark))
;; output is from original text
- (make-syntax-object
- (syntax-object-expression x)
+ (make-syntax
+ (syntax-expression x)
(make-wrap (cdr ms) (if rib (cons rib (cdr ss))
(cdr ss)))
- (syntax-object-module x))
+ (syntax-module x))
;; output introduced by macro
- (make-syntax-object
- (decorate-source (syntax-object-expression x) s)
+ (make-syntax
+ (decorate-source (syntax-expression x) s)
(make-wrap (cons m ms)
(if rib
(cons rib (cons 'shift ss))
(cons 'shift ss)))
- (syntax-object-module x))))))
+ (syntax-module x))))))
((vector? x)
(let* ((n (vector-length x))
@@ -1746,9 +1725,9 @@
;; comparison is done using 'bound-id=?'.
(call-with-values
(lambda () (resolve-identifier
- (make-syntax-object '#{ $sc-ellipsis }#
- (syntax-object-wrap e)
- (syntax-object-module e))
+ (make-syntax '#{ $sc-ellipsis }#
+ (syntax-wrap e)
+ (syntax-module e))
empty-wrap r mod #f))
(lambda (type value mod)
(if (eq? type 'ellipsis)
@@ -1964,7 +1943,7 @@
;; data
- ;; strips syntax-objects down to top-wrap
+ ;; strips syntax objects down to top-wrap
;;
;; since only the head of a list is annotated by the reader, not each pair
;; in the spine, we also check for pairs whose cars are annotated in case
@@ -1976,8 +1955,8 @@
x
(let f ((x x))
(cond
- ((syntax-object? x)
- (strip (syntax-object-expression x) (syntax-object-wrap x)))
+ ((syntax? x)
+ (strip (syntax-expression x) (syntax-wrap x)))
((pair? x)
(let ((a (f (car x))) (d (f (cdr x))))
(if (and (eq? a (car x)) (eq? d (cdr x)))
@@ -1999,7 +1978,7 @@
(define gen-var
(lambda (id)
- (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (let ((id (if (syntax? id) (syntax-expression id) id)))
(build-lexical-var no-source id))))
;; appears to return a reversed list
@@ -2010,10 +1989,10 @@
((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
((id? vars) (cons (wrap vars w #f) ls))
((null? vars) ls)
- ((syntax-object? vars)
- (lvl (syntax-object-expression vars)
+ ((syntax? vars)
+ (lvl (syntax-expression vars)
ls
- (join-wraps w (syntax-object-wrap vars))))
+ (join-wraps w (syntax-wrap vars))))
;; include anything else to be caught by subsequent error
;; checking
(else (cons vars ls))))))
@@ -2309,9 +2288,9 @@
(id? #'dots)
(let ((id (if (symbol? #'dots)
'#{ $sc-ellipsis }#
- (make-syntax-object '#{ $sc-ellipsis }#
- (syntax-object-wrap
#'dots)
-
(syntax-object-module #'dots)))))
+ (make-syntax '#{ $sc-ellipsis }#
+ (syntax-wrap #'dots)
+ (syntax-module
#'dots)))))
(let ((ids (list id))
(labels (list (gen-label)))
(bindings (list (make-binding 'ellipsis
(source-wrap #'dots w s mod)))))
@@ -2463,10 +2442,10 @@
(cond ((pair? x)
(cons (remodulate (car x) mod)
(remodulate (cdr x) mod)))
- ((syntax-object? x)
- (make-syntax-object
- (remodulate (syntax-object-expression x) mod)
- (syntax-object-wrap x)
+ ((syntax? x)
+ (make-syntax
+ (remodulate (syntax-expression x) mod)
+ (syntax-wrap x)
;; hither the remodulation
mod))
((vector? x)
@@ -2478,8 +2457,8 @@
(syntax-case e (@@ primitive)
((_ primitive id)
(and (id? #'id)
- (equal? (cdr (if (syntax-object? #'id)
- (syntax-object-module #'id)
+ (equal? (cdr (if (syntax? #'id)
+ (syntax-module #'id)
mod))
'(guile)))
;; Strip the wrap from the identifier and return
top-wrap
@@ -2726,8 +2705,8 @@
(set! datum->syntax
(lambda (id datum)
- (make-syntax-object datum (syntax-object-wrap id)
- (syntax-object-module id))))
+ (make-syntax datum (syntax-wrap id)
+ (syntax-module id))))
(set! syntax->datum
;; accepts any object, since syntax objects may consist partially
@@ -2772,7 +2751,7 @@
(let ()
(define (%syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module)
- (let ((mod (syntax-object-module id)))
+ (let ((mod (syntax-module id)))
(and (not (equal? mod '(primitive)))
(cdr mod))))
@@ -2789,10 +2768,10 @@
(make-wrap ms (if rib (cons rib s) s)))))
(call-with-values (lambda ()
(resolve-identifier
- (syntax-object-expression id)
- (strip-anti-mark (syntax-object-wrap id))
+ (syntax-expression id)
+ (strip-anti-mark (syntax-wrap id))
r
- (syntax-object-module id)
+ (syntax-module id)
resolve-syntax-parameters?))
(lambda (type value mod)
(case type
@@ -2807,15 +2786,15 @@
(values 'global (cons value (cdr mod)))))
((ellipsis)
(values 'ellipsis
- (make-syntax-object (syntax-object-expression value)
- (anti-mark (syntax-object-wrap
value))
- (syntax-object-module value))))
+ (make-syntax (syntax-expression value)
+ (anti-mark (syntax-wrap value))
+ (syntax-module value))))
(else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id)
(arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
- (locally-bound-identifiers (syntax-object-wrap id)
- (syntax-object-module id)))
+ (locally-bound-identifiers (syntax-wrap id)
+ (syntax-module id)))
;; Using define! instead of set! to avoid warnings at
;; compile-time, after the variables are stolen away into (system
@@ -2859,11 +2838,11 @@
(let ((rest (match-each (cdr e) p w mod)))
(and rest (cons first rest))))))
((null? e) '())
- ((syntax-object? e)
- (match-each (syntax-object-expression e)
+ ((syntax? e)
+ (match-each (syntax-expression e)
p
- (join-wraps w (syntax-object-wrap e))
- (syntax-object-module e)))
+ (join-wraps w (syntax-wrap e))
+ (syntax-module e)))
(else #f))))
(define match-each+
@@ -2884,9 +2863,9 @@
(cdr y-pat)
(match (car e) (car y-pat) w r mod)))
(values #f #f #f)))))
- ((syntax-object? e)
- (f (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))))
+ ((syntax? e)
+ (f (syntax-expression e)
+ (join-wraps w (syntax-wrap e))))
(else
(values '() y-pat (match e z-pat w r mod)))))))
@@ -2897,9 +2876,9 @@
(let ((l (match-each-any (cdr e) w mod)))
(and l (cons (wrap (car e) w mod) l))))
((null? e) '())
- ((syntax-object? e)
- (match-each-any (syntax-object-expression e)
- (join-wraps w (syntax-object-wrap e))
+ ((syntax? e)
+ (match-each-any (syntax-expression e)
+ (join-wraps w (syntax-wrap e))
mod))
(else #f))))
@@ -2970,13 +2949,13 @@
((not r) #f)
((eq? p '_) r)
((eq? p 'any) (cons (wrap e w mod) r))
- ((syntax-object? e)
+ ((syntax? e)
(match*
- (syntax-object-expression e)
+ (syntax-expression e)
p
- (join-wraps w (syntax-object-wrap e))
+ (join-wraps w (syntax-wrap e))
r
- (syntax-object-module e)))
+ (syntax-module e)))
(else (match* e p w r mod)))))
(set! $sc-dispatch
@@ -2984,9 +2963,9 @@
(cond
((eq? p 'any) (list e))
((eq? p '_) '())
- ((syntax-object? e)
- (match* (syntax-object-expression e)
- p (syntax-object-wrap e) '() (syntax-object-module e)))
+ ((syntax? e)
+ (match* (syntax-expression e)
+ p (syntax-wrap e) '() (syntax-module e)))
(else (match* e p empty-wrap '() #f))))))))