mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Psyntax generates new syntax objects

Browse source 
* module/ice-9/psyntax.scm (make-syntax-object): Change to make
  new-style syntax objects.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/compile-psyntax.scm (squeeze-syntax-object): Change to be
  functional.
  (squeeze-constant): Likewise.
  (squeeze-tree-il): Likewise.
  (translate-literal-syntax-objects): New pass.  The compiler can embed
  literal syntax objects into compiled objects, but syntax can no longer
  be read/written; otherwise users could forge syntax objects.  So for
  the bootstrap phase, rewrite literal constants to calls to
  make-syntax.
This commit is contained in:
Andy Wingo 2017-03-27 22:22:19 +02:00
parent eb84c2f2da
commit a42bfae65f
3 changed files with 950 additions and 857 deletions
Download patch file Download diff file Expand all files Collapse all files

124
module/ice-9/compile-psyntax.scm
View file

@ -20,67 +20,132 @@
(language tree-il primitives) (language tree-il primitives)
(language tree-il canonicalize) (language tree-il canonicalize)
(srfi srfi-1) (srfi srfi-1)
(ice-9 control)
(ice-9 pretty-print) (ice-9 pretty-print)
(system syntax)) (system syntax internal))
;; Minimize a syntax-object such that it can no longer be used as the ;; Minimize a syntax-object such that it can no longer be used as the
;; first argument to 'datum->syntax', but is otherwise equivalent. ;; first argument to 'datum->syntax', but is otherwise equivalent.
(define (squeeze-syntax-object! syn) (define (squeeze-syntax-object syn)
(define (ensure-list x) (if (vector? x) (vector->list x) x)) (define (ensure-list x) (if (vector? x) (vector->list x) x))
(let ((x (vector-ref syn 1)) (let ((x (syntax-expression syn))
(wrap (vector-ref syn 2)) (wrap (syntax-wrap syn))
(mod (vector-ref syn 3))) (mod (syntax-module syn)))
(let ((marks (car wrap)) (let ((marks (car wrap))
(subst (cdr wrap))) (subst (cdr wrap)))
(define (set-wrap! marks subst) (define (squeeze-wrap marks subst)
(vector-set! syn 2 (cons marks subst))) (make-syntax x (cons marks subst) mod))
(cond (cond
((symbol? x) ((symbol? x)
(let loop ((marks marks) (subst subst)) (let loop ((marks marks) (subst subst))
(cond (cond
((null? subst) (set-wrap! marks subst) syn) ((null? subst) (squeeze-wrap marks subst))
((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst))) ((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst)))
((find (lambda (entry) (and (eq? x (car entry)) ((find (lambda (entry) (and (eq? x (car entry))
(equal? marks (cadr entry)))) (equal? marks (cadr entry))))
(apply map list (map ensure-list (apply map list (map ensure-list
(cdr (vector->list (car subst)))))) (cdr (vector->list (car subst))))))
=> (lambda (entry) => (lambda (entry)
(set-wrap! marks (squeeze-wrap marks
(list (list->vector (list (list->vector
(cons 'ribcage (cons 'ribcage
(map vector entry))))) (map vector entry)))))))
syn))
(else (loop marks (cdr subst)))))) (else (loop marks (cdr subst))))))
((or (pair? x) (vector? x)) ((or (pair? x) (vector? x)) syn)
syn)
(else x))))) (else x)))))
(define (squeeze-constant! x) (define (squeeze-constant x)
(define (syntax-object? x) (cond ((syntax? x) (squeeze-syntax-object x))
(and (vector? x)
(= 4 (vector-length x))
(eq? 'syntax-object (vector-ref x 0))))
(cond ((syntax-object? x)
(squeeze-syntax-object! x))
((pair? x) ((pair? x)
(set-car! x (squeeze-constant! (car x))) (cons (squeeze-constant (car x))
(set-cdr! x (squeeze-constant! (cdr x))) (squeeze-constant (cdr x))))
x)
((vector? x) ((vector? x)
(for-each (lambda (i) (list->vector (squeeze-constant (vector->list x))))
(vector-set! x i (squeeze-constant! (vector-ref x i))))
(iota (vector-length x)))
x)
(else x))) (else x)))
(define (squeeze-tree-il x) (define (squeeze-tree-il x)
(post-order (lambda (x) (post-order (lambda (x)
(if (const? x) (if (const? x)
(make-const (const-src x) (make-const (const-src x)
(squeeze-constant! (const-exp x))) (squeeze-constant (const-exp x)))
x)) x))
x)) x))
(define (translate-literal-syntax-objects x)
(define (find-make-syntax-lexical-binding x)
(let/ec return
(pre-order (lambda (x)
(when (let? x)
(for-each (lambda (name sym)
(when (eq? name 'make-syntax)
(return sym)))
(let-names x) (let-gensyms x)))
x)
x)
#f))
(let ((make-syntax-gensym (find-make-syntax-lexical-binding x))
(retry-tag (make-prompt-tag)))
(define (translate-constant x)
(let ((src (const-src x))
(exp (const-exp x)))
(cond
((list? exp)
(let ((exp (map (lambda (x)
(translate-constant (make-const src x)))
exp)))
(if (and-map const? exp)
x
(make-primcall src 'list exp))))
((pair? exp)
(let ((car (translate-constant (make-const src (car exp))))
(cdr (translate-constant (make-const src (cdr exp)))))
(if (and (const? car) (const? cdr))
x
(make-primcall src 'cons (list car cdr)))))
((vector? exp)
(let ((exp (map (lambda (x)
(translate-constant (make-const src x)))
(vector->list exp))))
(if (and-map const? exp)
x
(make-primcall src 'vector exp))))
((syntax? exp)
(make-call src
(if make-syntax-gensym
(make-lexical-ref src 'make-syntax
make-syntax-gensym)
(abort-to-prompt retry-tag))
(list
(translate-constant
(make-const src (syntax-expression exp)))
(translate-constant
(make-const src (syntax-wrap exp)))
(translate-constant
(make-const src (syntax-module exp))))))
(else x))))
(call-with-prompt retry-tag
(lambda ()
(post-order (lambda (x)
(if (const? x)
(translate-constant x)
x))
x))
(lambda (k)
;; OK, we have a syntax object embedded in this code, but
;; make-syntax isn't lexically bound. This is the case for the
;; top-level macro definitions in psyntax that follow the main
;; let blob. Attach a lexical binding and retry.
(unless (toplevel-define? x) (error "unexpected"))
(translate-literal-syntax-objects
(make-toplevel-define
(toplevel-define-src x)
(toplevel-define-name x)
(make-let (toplevel-define-src x)
(list 'make-syntax)
(list (module-gensym))
(list (make-toplevel-ref #f 'make-syntax))
(toplevel-define-exp x))))))))
;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels
;; changing session identifiers. ;; changing session identifiers.
(set! syntax-session-id (lambda () "*")) (set! syntax-session-id (lambda () "*"))
@ -99,11 +164,12 @@
(close-port in)) (close-port in))
(begin (begin
(pretty-print (tree-il->scheme (pretty-print (tree-il->scheme
(translate-literal-syntax-objects
(squeeze-tree-il (squeeze-tree-il
(canonicalize (canonicalize
(resolve-primitives (resolve-primitives
(macroexpand x 'c '(compile load eval)) (macroexpand x 'c '(compile load eval))
(current-module)))) (current-module)))))
(current-module) (current-module)
(list #:avoid-lambda? #f (list #:avoid-lambda? #f
#:use-case? #f #:use-case? #f

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

@ -246,7 +246,7 @@
(eqv? (vector-ref x 0) 'syntax-object))))) (eqv? (vector-ref x 0) 'syntax-object)))))
(make-syntax-object (make-syntax-object
(lambda (expression wrap module) (lambda (expression wrap module)
(vector 'syntax-object expression wrap module))) (make-syntax expression wrap module)))
(syntax-object-expression (syntax-object-expression
(lambda (obj) (lambda (obj)
(if (syntax? obj) (syntax-expression obj) (vector-ref obj 1)))) (if (syntax? obj) (syntax-expression obj) (vector-ref obj 1))))
@ -792,7 +792,7 @@
(wrap name w mod) (wrap name w mod)
(wrap e w mod) (wrap e w mod)
(decorate-source (decorate-source
(cons '#(syntax-object lambda ((top)) (hygiene guile)) (cons (make-syntax 'lambda '((top)) '(hygiene guile))
(wrap (cons args (cons e1 e2)) w mod)) (wrap (cons args (cons e1 e2)) w mod))
s) s)
'(()) '(())
@ -806,7 +806,7 @@
'define-form 'define-form
(wrap name w mod) (wrap name w mod)
(wrap e w mod) (wrap e w mod)
'(#(syntax-object if ((top)) (hygiene guile)) #f #f) (list (make-syntax 'if '((top)) '(hygiene guile)) #f #f)
'(()) '(())
s s
mod)) mod))
@ -1174,7 +1174,7 @@
(lambda (type value mod) (lambda (type value mod)
(if (eq? type 'ellipsis) (if (eq? type 'ellipsis)
(bound-id=? e value) (bound-id=? e value)
(free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))) (free-id=? e (make-syntax '... '((top)) '(hygiene guile)))))))))
(lambda-formals (lambda-formals
(lambda (orig-args) (lambda (orig-args)
(letrec* (letrec*
@ -2067,7 +2067,7 @@
(build-call (build-call
s s
(expand (expand
(list '#(syntax-object setter ((top)) (hygiene guile)) head) (list (make-syntax 'setter '((top)) '(hygiene guile)) head)
r r
w w
mod) mod)
@ -2088,7 +2088,7 @@
'((top)) '((top))
#f #f
(syntax->datum (syntax->datum
(cons '#(syntax-object public ((top)) (hygiene guile)) mod)))) (cons (make-syntax 'public '((top)) '(hygiene guile)) mod))))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2119,7 +2119,9 @@
(let* ((tmp e) (let* ((tmp e)
(tmp-1 ($sc-dispatch (tmp-1 ($sc-dispatch
tmp tmp
'(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any)))) (list '_
(vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile)))
'any))))
(if (and tmp-1 (if (and tmp-1
(apply (lambda (id) (apply (lambda (id)
(and (id? id) (and (id? id)
@ -2139,17 +2141,18 @@
'((top)) '((top))
#f #f
(syntax->datum (syntax->datum
(cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) (cons (make-syntax 'private '((top)) '(hygiene guile)) mod))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch (let ((tmp-1 ($sc-dispatch
tmp tmp
'(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) (list '_
each-any (vector 'free-id (make-syntax '@@ '((top)) '(hygiene guile)))
any)))) 'each-any
'any))))
(if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1))
(apply (lambda (mod exp) (apply (lambda (mod exp)
(let ((mod (syntax->datum (let ((mod (syntax->datum
(cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) (cons (make-syntax 'private '((top)) '(hygiene guile)) mod))))
(values (remodulate exp mod) r w (source-annotation exp) mod))) (values (remodulate exp mod) r w (source-annotation exp) mod)))
tmp-1) tmp-1)
(syntax-violation (syntax-violation
@ -2213,7 +2216,7 @@
(cvt (lambda (p n ids) (cvt (lambda (p n ids)
(if (id? p) (if (id? p)
(cond ((bound-id-member? p keys) (values (vector 'free-id p) ids)) (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
((free-id=? p '#(syntax-object _ ((top)) (hygiene guile))) ((free-id=? p (make-syntax '_ '((top)) '(hygiene guile)))
(values '_ ids)) (values '_ ids))
(else (values 'any (cons (cons p n) ids)))) (else (values 'any (cons (cons p n) ids))))
(let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
@ -2334,8 +2337,8 @@
(if (and (id? pat) (if (and (id? pat)
(and-map (and-map
(lambda (x) (not (free-id=? pat x))) (lambda (x) (not (free-id=? pat x)))
(cons '#(syntax-object ... ((top)) (hygiene guile)) keys))) (cons (make-syntax '... '((top)) '(hygiene guile)) keys)))
(if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile))) (if (free-id=? pat (make-syntax '_ '((top)) '(hygiene guile)))
(expand exp r '(()) mod) (expand exp r '(()) mod)
(let ((labels (list (gen-label))) (var (gen-var pat))) (let ((labels (list (gen-label))) (var (gen-var pat)))
(build-call (build-call
@ -2644,6 +2647,7 @@
(else (match* e p '(()) '() #f)))))))) (else (match* e p '(()) '() #f))))))))
(define with-syntax (define with-syntax
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'with-syntax 'with-syntax
'macro 'macro
@ -2652,35 +2656,36 @@
(let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (e1 e2) (apply (lambda (e1 e2)
(cons '#(syntax-object let ((top)) (hygiene guile)) (cons (make-syntax 'let '((top)) '(hygiene guile))
(cons '() (cons e1 e2)))) (cons '() (cons e1 e2))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (out in e1 e2) (apply (lambda (out in e1 e2)
(list '#(syntax-object syntax-case ((top)) (hygiene guile)) (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
in in
'() '()
(list out (list out
(cons '#(syntax-object let ((top)) (hygiene guile)) (cons (make-syntax 'let '((top)) '(hygiene guile))
(cons '() (cons e1 e2)))))) (cons '() (cons e1 e2))))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (out in e1 e2) (apply (lambda (out in e1 e2)
(list '#(syntax-object syntax-case ((top)) (hygiene guile)) (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
(cons '#(syntax-object list ((top)) (hygiene guile)) in) (cons (make-syntax 'list '((top)) '(hygiene guile)) in)
'() '()
(list out (list out
(cons '#(syntax-object let ((top)) (hygiene guile)) (cons (make-syntax 'let '((top)) '(hygiene guile))
(cons '() (cons e1 e2)))))) (cons '() (cons e1 e2))))))
tmp-1) tmp-1)
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp))))))))))) tmp))))))))))))
(define syntax-error (define syntax-error
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'syntax-error 'syntax-error
'macro 'macro
@ -2705,24 +2710,26 @@
(apply (lambda (message arg) (string? (syntax->datum message))) tmp) (apply (lambda (message arg) (string? (syntax->datum message))) tmp)
#f) #f)
(apply (lambda (message arg) (apply (lambda (message arg)
(cons '#(syntax-object (cons (make-syntax
syntax-error 'syntax-error
((top) (list '(top)
#(ribcage (vector
#(syntax-error) 'ribcage
#((top)) '#(syntax-error)
#(((hygiene guile) '#((top))
. (vector
#(syntax-object syntax-error ((top)) (hygiene guile)))))) (cons '(hygiene guile)
(hygiene guile)) (make-syntax 'syntax-error '((top)) '(hygiene guile))))))
'(hygiene guile))
(cons '(#f) (cons message arg)))) (cons '(#f) (cons message arg))))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1))))))))) tmp-1))))))))))
(define syntax-rules (define syntax-rules
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'syntax-rules 'syntax-rules
'macro 'macro
@ -2733,28 +2740,28 @@
(let ((tmp-1 clause)) (let ((tmp-1 clause))
(let ((tmp ($sc-dispatch (let ((tmp ($sc-dispatch
tmp-1 tmp-1
'((any . any) (list '(any . any)
(#(free-id #(syntax-object syntax-error ((top)) (hygiene guile))) (cons (vector
any 'free-id
. (make-syntax 'syntax-error '((top)) '(hygiene guile)))
each-any))))) '(any . each-any))))))
(if (if tmp (if (if tmp
(apply (lambda (keyword pattern message arg) (apply (lambda (keyword pattern message arg)
(string? (syntax->datum message))) (string? (syntax->datum message)))
tmp) tmp)
#f) #f)
(apply (lambda (keyword pattern message arg) (apply (lambda (keyword pattern message arg)
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern) (list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
(list '#(syntax-object syntax ((top)) (hygiene guile)) (list (make-syntax 'syntax '((top)) '(hygiene guile))
(cons '#(syntax-object syntax-error ((top)) (hygiene guile)) (cons (make-syntax 'syntax-error '((top)) '(hygiene guile))
(cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern) (cons (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
(cons message arg)))))) (cons message arg))))))
tmp) tmp)
(let ((tmp ($sc-dispatch tmp-1 '((any . any) any)))) (let ((tmp ($sc-dispatch tmp-1 '((any . any) any))))
(if tmp (if tmp
(apply (lambda (keyword pattern template) (apply (lambda (keyword pattern template)
(list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern) (list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern)
(list '#(syntax-object syntax ((top)) (hygiene guile)) template))) (list (make-syntax 'syntax '((top)) '(hygiene guile)) template)))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -2768,36 +2775,36 @@
'(each-any each-any #(each ((any . any) any)) each-any)))) '(each-any each-any #(each ((any . any) any)) each-any))))
(if tmp (if tmp
(apply (lambda (k docstring keyword pattern template clause) (apply (lambda (k docstring keyword pattern template clause)
(let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile)) (let ((tmp (cons (make-syntax 'lambda '((top)) '(hygiene guile))
(cons '(#(syntax-object x ((top)) (hygiene guile))) (cons (list (make-syntax 'x '((top)) '(hygiene guile)))
(append (append
docstring docstring
(list (vector (list (vector
'(#(syntax-object macro-type ((top)) (hygiene guile)) (cons (make-syntax 'macro-type '((top)) '(hygiene guile))
. (make-syntax
#(syntax-object 'syntax-rules
syntax-rules (list '(top)
((top) (vector
#(ribcage 'ribcage
#(syntax-rules) '#(syntax-rules)
#((top)) '#((top))
#(((hygiene guile) (vector
. (cons '(hygiene guile)
#(syntax-object (make-syntax
syntax-rules 'syntax-rules
((top)) '((top))
(hygiene guile)))))) '(hygiene guile))))))
(hygiene guile))) '(hygiene guile)))
(cons '#(syntax-object patterns ((top)) (hygiene guile)) (cons (make-syntax 'patterns '((top)) '(hygiene guile))
pattern)) pattern))
(cons '#(syntax-object syntax-case ((top)) (hygiene guile)) (cons (make-syntax 'syntax-case '((top)) '(hygiene guile))
(cons '#(syntax-object x ((top)) (hygiene guile)) (cons (make-syntax 'x '((top)) '(hygiene guile))
(cons k clause))))))))) (cons k clause)))))))))
(let ((form tmp)) (let ((form tmp))
(if dots (if dots
(let ((tmp dots)) (let ((tmp dots))
(let ((dots tmp)) (let ((dots tmp))
(list '#(syntax-object with-ellipsis ((top)) (hygiene guile)) (list (make-syntax 'with-ellipsis '((top)) '(hygiene guile))
dots dots
form))) form)))
form)))) form))))
@ -2832,11 +2839,9 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-116f (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-116f)
tmp-680b775fb37a463-116e (list (cons tmp-680b775fb37a463-116f tmp-680b775fb37a463)
tmp-680b775fb37a463-116d) tmp-680b775fb37a463-1))
(list (cons tmp-680b775fb37a463-116d tmp-680b775fb37a463-116e)
tmp-680b775fb37a463-116f))
template template
pattern pattern
keyword))) keyword)))
@ -2851,9 +2856,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-2)) tmp-680b775fb37a463-118a))
template template
pattern pattern
keyword))) keyword)))
@ -2869,11 +2874,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-11a7 (map (lambda (tmp-680b775fb37a463-11a9
tmp-680b775fb37a463-11a6 tmp-680b775fb37a463-11a8
tmp-680b775fb37a463-11a5) tmp-680b775fb37a463-11a7)
(list (cons tmp-680b775fb37a463-11a5 tmp-680b775fb37a463-11a6) (list (cons tmp-680b775fb37a463-11a7 tmp-680b775fb37a463-11a8)
tmp-680b775fb37a463-11a7)) tmp-680b775fb37a463-11a9))
template template
pattern pattern
keyword))) keyword)))
@ -2881,9 +2886,10 @@
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp)))))))))))))) tmp)))))))))))))))
(define define-syntax-rule (define define-syntax-rule
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'define-syntax-rule 'define-syntax-rule
'macro 'macro
@ -2892,11 +2898,11 @@
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any)))) (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
(if tmp (if tmp
(apply (lambda (name pattern template) (apply (lambda (name pattern template)
(list '#(syntax-object define-syntax ((top)) (hygiene guile)) (list (make-syntax 'define-syntax '((top)) '(hygiene guile))
name name
(list '#(syntax-object syntax-rules ((top)) (hygiene guile)) (list (make-syntax 'syntax-rules '((top)) '(hygiene guile))
'() '()
(list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) (list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern)
template)))) template))))
tmp) tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any)))) (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
@ -2906,20 +2912,21 @@
tmp) tmp)
#f) #f)
(apply (lambda (name pattern docstring template) (apply (lambda (name pattern docstring template)
(list '#(syntax-object define-syntax ((top)) (hygiene guile)) (list (make-syntax 'define-syntax '((top)) '(hygiene guile))
name name
(list '#(syntax-object syntax-rules ((top)) (hygiene guile)) (list (make-syntax 'syntax-rules '((top)) '(hygiene guile))
'() '()
docstring docstring
(list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) (list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern)
template)))) template))))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1))))))))) tmp-1))))))))))
(define let* (define let*
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'let* 'let*
'macro 'macro
@ -2932,13 +2939,13 @@
(apply (lambda (let* x v e1 e2) (apply (lambda (let* x v e1 e2)
(let f ((bindings (map list x v))) (let f ((bindings (map list x v)))
(if (null? bindings) (if (null? bindings)
(cons '#(syntax-object let ((top)) (hygiene guile)) (cons (make-syntax 'let '((top)) '(hygiene guile))
(cons '() (cons e1 e2))) (cons '() (cons e1 e2)))
(let ((tmp-1 (list (f (cdr bindings)) (car bindings)))) (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (body binding) (apply (lambda (body binding)
(list '#(syntax-object let ((top)) (hygiene guile)) (list (make-syntax 'let '((top)) '(hygiene guile))
(list binding) (list binding)
body)) body))
tmp) tmp)
@ -2950,9 +2957,10 @@
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1))))))) tmp-1))))))))
(define quasiquote (define quasiquote
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'quasiquote 'quasiquote
'macro 'macro
@ -2961,43 +2969,47 @@
(let ((tmp p)) (let ((tmp p))
(let ((tmp-1 ($sc-dispatch (let ((tmp-1 ($sc-dispatch
tmp tmp
'(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any)))) (list (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile)))
'any))))
(if tmp-1 (if tmp-1
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(list "value" p) (list "value" p)
(quasicons (quasicons
'("quote" #(syntax-object unquote ((top)) (hygiene guile))) (list "quote" (make-syntax 'unquote '((top)) '(hygiene guile)))
(quasi (list p) (- lev 1))))) (quasi (list p) (- lev 1)))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch (let ((tmp-1 ($sc-dispatch
tmp tmp
'(#(free-id (list (vector
#(syntax-object 'free-id
quasiquote (make-syntax
((top) 'quasiquote
#(ribcage (list '(top)
#(quasiquote) (vector
#((top)) 'ribcage
#(((hygiene guile) '#(quasiquote)
. '#((top))
#(syntax-object quasiquote ((top)) (hygiene guile)))))) (vector
(hygiene guile))) (cons '(hygiene guile)
any)))) (make-syntax 'quasiquote '((top)) '(hygiene guile))))))
'(hygiene guile)))
'any))))
(if tmp-1 (if tmp-1
(apply (lambda (p) (apply (lambda (p)
(quasicons (quasicons
'("quote" (list "quote"
#(syntax-object (make-syntax
quasiquote 'quasiquote
((top) (list '(top)
#(ribcage (vector
#(quasiquote) 'ribcage
#((top)) '#(quasiquote)
#(((hygiene guile) '#((top))
. (vector
#(syntax-object quasiquote ((top)) (hygiene guile)))))) (cons '(hygiene guile)
(hygiene guile))) (make-syntax 'quasiquote '((top)) '(hygiene guile))))))
'(hygiene guile)))
(quasi (list p) (+ lev 1)))) (quasi (list p) (+ lev 1))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(any . any)))) (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
@ -3006,29 +3018,34 @@
(let ((tmp-1 p)) (let ((tmp-1 p))
(let ((tmp ($sc-dispatch (let ((tmp ($sc-dispatch
tmp-1 tmp-1
'(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) (cons (vector
. 'free-id
each-any)))) (make-syntax 'unquote '((top)) '(hygiene guile)))
'each-any))))
(if tmp (if tmp
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-120f) (map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463-120f)) (list "value" tmp-680b775fb37a463))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
(quasicons (quasicons
'("quote" #(syntax-object unquote ((top)) (hygiene guile))) (list "quote"
(make-syntax 'unquote '((top)) '(hygiene guile)))
(quasi p (- lev 1))) (quasi p (- lev 1)))
(quasi q lev)))) (quasi q lev))))
tmp) tmp)
(let ((tmp ($sc-dispatch (let ((tmp ($sc-dispatch
tmp-1 tmp-1
'(#(free-id (cons (vector
#(syntax-object unquote-splicing ((top)) (hygiene guile))) 'free-id
. (make-syntax
each-any)))) 'unquote-splicing
'((top))
'(hygiene guile)))
'each-any))))
(if tmp (if tmp
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
@ -3039,11 +3056,11 @@
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
(quasicons (quasicons
'("quote" (list "quote"
#(syntax-object (make-syntax
unquote-splicing 'unquote-splicing
((top)) '((top))
(hygiene guile))) '(hygiene guile)))
(quasi p (- lev 1))) (quasi p (- lev 1)))
(quasi q lev)))) (quasi q lev))))
tmp) tmp)
@ -3062,39 +3079,40 @@
(let ((tmp-1 p)) (let ((tmp-1 p))
(let ((tmp ($sc-dispatch (let ((tmp ($sc-dispatch
tmp-1 tmp-1
'(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) (cons (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile)))
. 'each-any))))
each-any))))
(if tmp (if tmp
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-122a)
(list "value" tmp-680b775fb37a463-122a))
p)
(vquasi q lev))
(quasicons
(quasicons
'("quote" #(syntax-object unquote ((top)) (hygiene guile)))
(quasi p (- lev 1)))
(vquasi q lev))))
tmp)
(let ((tmp ($sc-dispatch
tmp-1
'(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
.
each-any))))
(if tmp
(apply (lambda (p)
(if (= lev 0)
(quasiappend
(map (lambda (tmp-680b775fb37a463-122f) (map (lambda (tmp-680b775fb37a463-122f)
(list "value" tmp-680b775fb37a463-122f)) (list "value" tmp-680b775fb37a463-122f))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
(quasicons (quasicons
'("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile))) (list "quote" (make-syntax 'unquote '((top)) '(hygiene guile)))
(quasi p (- lev 1)))
(vquasi q lev))))
tmp)
(let ((tmp ($sc-dispatch
tmp-1
(cons (vector
'free-id
(make-syntax 'unquote-splicing '((top)) '(hygiene guile)))
'each-any))))
(if tmp
(apply (lambda (p)
(if (= lev 0)
(quasiappend
(map (lambda (tmp-680b775fb37a463)
(list "value" tmp-680b775fb37a463))
p)
(vquasi q lev))
(quasicons
(quasicons
(list "quote"
(make-syntax 'unquote-splicing '((top)) '(hygiene guile)))
(quasi p (- lev 1))) (quasi p (- lev 1)))
(vquasi q lev)))) (vquasi q lev))))
tmp) tmp)
@ -3178,7 +3196,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) (cons "vector" t-680b775fb37a463)) (apply (lambda (t-680b775fb37a463-127d)
(cons "vector" t-680b775fb37a463-127d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3205,7 +3224,7 @@
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
(if tmp-1 (if tmp-1
(apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x)) (apply (lambda (x) (list (make-syntax 'quote '((top)) '(hygiene guile)) x))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
(if tmp-1 (if tmp-1
@ -3213,9 +3232,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-12a2) (apply (lambda (t-680b775fb37a463-12a7)
(cons '#(syntax-object list ((top)) (hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-12a2)) t-680b775fb37a463-12a7))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3231,10 +3250,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-12b6 t-680b775fb37a463-12b5) (apply (lambda (t-680b775fb37a463-12bb t-680b775fb37a463-12ba)
(list '#(syntax-object cons ((top)) (hygiene guile)) (list (make-syntax 'cons '((top)) '(hygiene guile))
t-680b775fb37a463-12b6 t-680b775fb37a463-12bb
t-680b775fb37a463-12b5)) t-680b775fb37a463-12ba))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3247,9 +3266,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-12c2) (apply (lambda (t-680b775fb37a463-12c7)
(cons '#(syntax-object append ((top)) (hygiene guile)) (cons (make-syntax 'append '((top)) '(hygiene guile))
t-680b775fb37a463-12c2)) t-680b775fb37a463-12c7))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3262,9 +3281,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-12ce) (apply (lambda (t-680b775fb37a463-12d3)
(cons '#(syntax-object vector ((top)) (hygiene guile)) (cons (make-syntax 'vector '((top)) '(hygiene guile))
t-680b775fb37a463-12ce)) t-680b775fb37a463-12d3))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3275,9 +3294,9 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463-12da tmp)) (let ((t-680b775fb37a463-12df tmp))
(list '#(syntax-object list->vector ((top)) (hygiene guile)) (list (make-syntax 'list->vector '((top)) '(hygiene guile))
t-680b775fb37a463-12da)))) t-680b775fb37a463-12df))))
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
@ -3294,9 +3313,10 @@
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1)))))))) tmp-1)))))))))
(define include (define include
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'include 'include
'macro 'macro
@ -3331,7 +3351,7 @@
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (exp) (apply (lambda (exp)
(cons '#(syntax-object begin ((top)) (hygiene guile)) exp)) (cons (make-syntax 'begin '((top)) '(hygiene guile)) exp))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3341,9 +3361,10 @@
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1))))))))))) tmp-1))))))))))))
(define include-from-path (define include-from-path
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'include-from-path 'include-from-path
'macro 'macro
@ -3365,12 +3386,12 @@
x x
filename))))))) filename)))))))
(let ((fn tmp)) (let ((fn tmp))
(list '#(syntax-object include ((top)) (hygiene guile)) fn))))) (list (make-syntax 'include '((top)) '(hygiene guile)) fn)))))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1))))))) tmp-1))))))))
(define unquote (define unquote
(make-syntax-transformer (make-syntax-transformer
@ -3401,6 +3422,7 @@
(error "variable transformer not a procedure" proc)))) (error "variable transformer not a procedure" proc))))
(define identifier-syntax (define identifier-syntax
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'identifier-syntax 'identifier-syntax
'macro 'macro
@ -3409,76 +3431,81 @@
(let ((tmp ($sc-dispatch tmp-1 '(_ any)))) (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
(if tmp (if tmp
(apply (lambda (e) (apply (lambda (e)
(list '#(syntax-object lambda ((top)) (hygiene guile)) (list (make-syntax 'lambda '((top)) '(hygiene guile))
'(#(syntax-object x ((top)) (hygiene guile))) (list (make-syntax 'x '((top)) '(hygiene guile)))
'#((#(syntax-object macro-type ((top)) (hygiene guile)) (vector
. (cons (make-syntax 'macro-type '((top)) '(hygiene guile))
#(syntax-object (make-syntax
identifier-syntax 'identifier-syntax
((top) (list '(top)
#(ribcage (vector
#(identifier-syntax) 'ribcage
#((top)) '#(identifier-syntax)
#(((hygiene guile) '#((top))
. (vector
#(syntax-object identifier-syntax ((top)) (hygiene guile)))))) (cons '(hygiene guile)
(hygiene guile)))) (make-syntax 'identifier-syntax '((top)) '(hygiene guile))))))
(list '#(syntax-object syntax-case ((top)) (hygiene guile)) '(hygiene guile))))
'#(syntax-object x ((top)) (hygiene guile)) (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
(make-syntax 'x '((top)) '(hygiene guile))
'() '()
(list '#(syntax-object id ((top)) (hygiene guile)) (list (make-syntax 'id '((top)) '(hygiene guile))
'(#(syntax-object identifier? ((top)) (hygiene guile)) (list (make-syntax 'identifier? '((top)) '(hygiene guile))
(#(syntax-object syntax ((top)) (hygiene guile)) (list (make-syntax 'syntax '((top)) '(hygiene guile))
#(syntax-object id ((top)) (hygiene guile)))) (make-syntax 'id '((top)) '(hygiene guile))))
(list '#(syntax-object syntax ((top)) (hygiene guile)) e)) (list (make-syntax 'syntax '((top)) '(hygiene guile)) e))
(list '(#(syntax-object _ ((top)) (hygiene guile)) (list (list (make-syntax '_ '((top)) '(hygiene guile))
#(syntax-object x ((top)) (hygiene guile)) (make-syntax 'x '((top)) '(hygiene guile))
#(syntax-object ... ((top)) (hygiene guile))) (make-syntax '... '((top)) '(hygiene guile)))
(list '#(syntax-object syntax ((top)) (hygiene guile)) (list (make-syntax 'syntax '((top)) '(hygiene guile))
(cons e (cons e
'(#(syntax-object x ((top)) (hygiene guile)) (list (make-syntax 'x '((top)) '(hygiene guile))
#(syntax-object ... ((top)) (hygiene guile))))))))) (make-syntax '... '((top)) '(hygiene guile)))))))))
tmp) tmp)
(let ((tmp ($sc-dispatch (let ((tmp ($sc-dispatch
tmp-1 tmp-1
'(_ (any any) (list '_
((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any) '(any any)
any))))) (list (list (vector 'free-id (make-syntax 'set! '((top)) '(hygiene guile)))
'any
'any)
'any)))))
(if (if tmp (if (if tmp
(apply (lambda (id exp1 var val exp2) (apply (lambda (id exp1 var val exp2)
(if (identifier? id) (identifier? var) #f)) (if (identifier? id) (identifier? var) #f))
tmp) tmp)
#f) #f)
(apply (lambda (id exp1 var val exp2) (apply (lambda (id exp1 var val exp2)
(list '#(syntax-object make-variable-transformer ((top)) (hygiene guile)) (list (make-syntax 'make-variable-transformer '((top)) '(hygiene guile))
(list '#(syntax-object lambda ((top)) (hygiene guile)) (list (make-syntax 'lambda '((top)) '(hygiene guile))
'(#(syntax-object x ((top)) (hygiene guile))) (list (make-syntax 'x '((top)) '(hygiene guile)))
'#((#(syntax-object macro-type ((top)) (hygiene guile)) (vector
. (cons (make-syntax 'macro-type '((top)) '(hygiene guile))
#(syntax-object variable-transformer ((top)) (hygiene guile)))) (make-syntax 'variable-transformer '((top)) '(hygiene guile))))
(list '#(syntax-object syntax-case ((top)) (hygiene guile)) (list (make-syntax 'syntax-case '((top)) '(hygiene guile))
'#(syntax-object x ((top)) (hygiene guile)) (make-syntax 'x '((top)) '(hygiene guile))
'(#(syntax-object set! ((top)) (hygiene guile))) (list (make-syntax 'set! '((top)) '(hygiene guile)))
(list (list '#(syntax-object set! ((top)) (hygiene guile)) var val) (list (list (make-syntax 'set! '((top)) '(hygiene guile)) var val)
(list '#(syntax-object syntax ((top)) (hygiene guile)) exp2)) (list (make-syntax 'syntax '((top)) '(hygiene guile)) exp2))
(list (cons id (list (cons id
'(#(syntax-object x ((top)) (hygiene guile)) (list (make-syntax 'x '((top)) '(hygiene guile))
#(syntax-object ... ((top)) (hygiene guile)))) (make-syntax '... '((top)) '(hygiene guile))))
(list '#(syntax-object syntax ((top)) (hygiene guile)) (list (make-syntax 'syntax '((top)) '(hygiene guile))
(cons exp1 (cons exp1
'(#(syntax-object x ((top)) (hygiene guile)) (list (make-syntax 'x '((top)) '(hygiene guile))
#(syntax-object ... ((top)) (hygiene guile)))))) (make-syntax '... '((top)) '(hygiene guile))))))
(list id (list id
(list '#(syntax-object identifier? ((top)) (hygiene guile)) (list (make-syntax 'identifier? '((top)) '(hygiene guile))
(list '#(syntax-object syntax ((top)) (hygiene guile)) id)) (list (make-syntax 'syntax '((top)) '(hygiene guile)) id))
(list '#(syntax-object syntax ((top)) (hygiene guile)) exp1)))))) (list (make-syntax 'syntax '((top)) '(hygiene guile)) exp1))))))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1))))))))) tmp-1))))))))))
(define define* (define define*
(let ((make-syntax make-syntax))
(make-syntax-transformer (make-syntax-transformer
'define* 'define*
'macro 'macro
@ -3487,18 +3514,18 @@
(let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any)))) (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
(if tmp (if tmp
(apply (lambda (id args b0 b1) (apply (lambda (id args b0 b1)
(list '#(syntax-object define ((top)) (hygiene guile)) (list (make-syntax 'define '((top)) '(hygiene guile))
id id
(cons '#(syntax-object lambda* ((top)) (hygiene guile)) (cons (make-syntax 'lambda* '((top)) '(hygiene guile))
(cons args (cons b0 b1))))) (cons args (cons b0 b1)))))
tmp) tmp)
(let ((tmp ($sc-dispatch tmp-1 '(_ any any)))) (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
(if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f) (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
(apply (lambda (id val) (apply (lambda (id val)
(list '#(syntax-object define ((top)) (hygiene guile)) id val)) (list (make-syntax 'define '((top)) '(hygiene guile)) id val))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
tmp-1))))))))) tmp-1))))))))))

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

@ -477,7 +477,7 @@
(= (vector-length x) 4) (= (vector-length x) 4)
(eqv? (vector-ref x 0) 'syntax-object)))) (eqv? (vector-ref x 0) 'syntax-object))))
(define (make-syntax-object expression wrap module) (define (make-syntax-object expression wrap module)
(vector 'syntax-object expression wrap module)) (make-syntax expression wrap module))
(define (syntax-object-expression obj) (define (syntax-object-expression obj)
(if (syntax? obj) (if (syntax? obj)
(syntax-expression obj) (syntax-expression obj)