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

allow definitions in with-syntax body

Browse source 
* module/ice-9/psyntax.scm (with-syntax): Allow definitions in the body,
  as seems to be suggested by the R6RS.

* test-suite/tests/syncase.test ("with-syntax"): Add test.

* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2011-03-31 13:23:27 +02:00
parent 0f1fd214f1
commit f929b9e5ec
3 changed files with 105 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -37,16 +37,10 @@
(begin (begin
(#{andmap\ 225}# #{first\ 203}# #{rest\ 204}#)))))))))) (#{andmap\ 225}# #{first\ 203}# #{rest\ 204}#))))))))))
(begin (begin
(let ((#{make-primitive-ref\ 244}# (if #f #f)) (let ((#{fx+\ 283}# (if #f #f))
(#{fx+\ 283}# (if #f #f))
(#{fx-\ 285}# (if #f #f)) (#{fx-\ 285}# (if #f #f))
(#{fx=\ 287}# (if #f #f)) (#{fx=\ 287}# (if #f #f))
(#{fx<\ 289}# (if #f #f)) (#{fx<\ 289}# (if #f #f)))
(#{set-syntax-object-expression!\ 354}#
(if #f #f))
(#{set-syntax-object-wrap!\ 356}# (if #f #f))
(#{set-syntax-object-module!\ 358}# (if #f #f))
(#{ribcage?\ 400}# (if #f #f)))
(letrec* (letrec*
((#{make-void\ 240}# ((#{make-void\ 240}#
(lambda (#{src\ 750}#) (lambda (#{src\ 750}#)
@ -7718,6 +7712,10 @@
'(#(syntax-object '(#(syntax-object
#f #f
((top) ((top)
#(ribcage
()
()
())
#(ribcage #(ribcage
#(k) #(k)
#((top)) #((top))
@ -8927,32 +8925,27 @@
(cons #{vars\ 2791}# #{ls\ 2792}#)))))))) (cons #{vars\ 2791}# #{ls\ 2792}#))))))))
(begin (#{lvl\ 2790}# #{vars\ 2784}# '() '(()))))))) (begin (#{lvl\ 2790}# #{vars\ 2784}# '() '(())))))))
(begin (begin
(set! #{make-primitive-ref\ 244}#
(lambda (#{src\ 756}# #{name\ 757}#) (lambda (#{src\ 756}# #{name\ 757}#)
(make-struct/no-tail (make-struct/no-tail
(vector-ref %expanded-vtables 2) (vector-ref %expanded-vtables 2)
#{src\ 756}# #{src\ 756}#
#{name\ 757}#))) #{name\ 757}#))
(set! #{fx+\ 283}# +)
(set! #{fx-\ 285}# -)
(set! #{fx=\ 287}# =)
(set! #{fx<\ 289}# <)
(set! #{set-syntax-object-expression!\ 354}#
(lambda (#{x\ 1134}# #{update\ 1135}#) (lambda (#{x\ 1134}# #{update\ 1135}#)
(vector-set! #{x\ 1134}# 1 #{update\ 1135}#))) (vector-set! #{x\ 1134}# 1 #{update\ 1135}#))
(set! #{set-syntax-object-wrap!\ 356}#
(lambda (#{x\ 1138}# #{update\ 1139}#) (lambda (#{x\ 1138}# #{update\ 1139}#)
(vector-set! #{x\ 1138}# 2 #{update\ 1139}#))) (vector-set! #{x\ 1138}# 2 #{update\ 1139}#))
(set! #{set-syntax-object-module!\ 358}#
(lambda (#{x\ 1142}# #{update\ 1143}#) (lambda (#{x\ 1142}# #{update\ 1143}#)
(vector-set! #{x\ 1142}# 3 #{update\ 1143}#))) (vector-set! #{x\ 1142}# 3 #{update\ 1143}#))
(set! #{ribcage?\ 400}#
(lambda (#{x\ 1223}#) (lambda (#{x\ 1223}#)
(if (vector? #{x\ 1223}#) (if (vector? #{x\ 1223}#)
(if (= (vector-length #{x\ 1223}#) 4) (if (= (vector-length #{x\ 1223}#) 4)
(eq? (vector-ref #{x\ 1223}# 0) 'ribcage) (eq? (vector-ref #{x\ 1223}# 0) 'ribcage)
#f) #f)
#f))) #f))
(set! #{fx+\ 283}# +)
(set! #{fx-\ 285}# -)
(set! #{fx=\ 287}# =)
(set! #{fx<\ 289}# <)
(begin (begin
(#{global-extend\ 376}# (#{global-extend\ 376}#
'local-syntax 'local-syntax
@ -14515,7 +14508,7 @@
(@apply (@apply
(lambda (#{e1\ 4203}# #{e2\ 4204}#) (lambda (#{e1\ 4203}# #{e2\ 4204}#)
(cons '#(syntax-object (cons '#(syntax-object
begin let
((top) ((top)
#(ribcage #(ribcage
#(e1 e2) #(e1 e2)
@ -14524,7 +14517,7 @@
#(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i4198"))) #(ribcage #(x) #((top)) #("i4198")))
(hygiene guile)) (hygiene guile))
(cons #{e1\ 4203}# #{e2\ 4204}#))) (cons '() (cons #{e1\ 4203}# #{e2\ 4204}#))))
#{tmp\ 4200}#) #{tmp\ 4200}#)
(let ((#{tmp\ 4206}# (let ((#{tmp\ 4206}#
($sc-dispatch ($sc-dispatch
@ -14550,7 +14543,7 @@
'() '()
(list #{out\ 4211}# (list #{out\ 4211}#
(cons '#(syntax-object (cons '#(syntax-object
begin let
((top) ((top)
#(ribcage #(ribcage
#(out in e1 e2) #(out in e1 e2)
@ -14559,7 +14552,9 @@
#(ribcage () () ()) #(ribcage () () ())
#(ribcage #(x) #((top)) #("i4198"))) #(ribcage #(x) #((top)) #("i4198")))
(hygiene guile)) (hygiene guile))
(cons #{e1\ 4213}# #{e2\ 4214}#))))) (cons '()
(cons #{e1\ 4213}#
#{e2\ 4214}#))))))
#{tmp\ 4206}#) #{tmp\ 4206}#)
(let ((#{tmp\ 4216}# (let ((#{tmp\ 4216}#
($sc-dispatch ($sc-dispatch
@ -14595,7 +14590,7 @@
'() '()
(list #{out\ 4221}# (list #{out\ 4221}#
(cons '#(syntax-object (cons '#(syntax-object
begin let
((top) ((top)
#(ribcage #(ribcage
#(out in e1 e2) #(out in e1 e2)
@ -14610,7 +14605,9 @@
#((top)) #((top))
#("i4198"))) #("i4198")))
(hygiene guile)) (hygiene guile))
(cons #{e1\ 4223}# #{e2\ 4224}#))))) (cons '()
(cons #{e1\ 4223}#
#{e2\ 4224}#))))))
#{tmp\ 4216}#) #{tmp\ 4216}#)
(syntax-violation (syntax-violation
#f #f
@ -15006,6 +15003,7 @@
(list '#(syntax-object (list '#(syntax-object
let let
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(body binding) #(body binding)
#((top) (top)) #((top) (top))
@ -15104,6 +15102,7 @@
(list '#(syntax-object (list '#(syntax-object
let let
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15131,6 +15130,7 @@
'#(syntax-object '#(syntax-object
doloop doloop
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15161,6 +15161,7 @@
(list '#(syntax-object (list '#(syntax-object
if if
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15188,6 +15189,7 @@
(list '#(syntax-object (list '#(syntax-object
not not
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15221,6 +15223,7 @@
(cons '#(syntax-object (cons '#(syntax-object
begin begin
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15255,6 +15258,10 @@
(list (cons '#(syntax-object (list (cons '#(syntax-object
doloop doloop
((top) ((top)
#(ribcage
()
()
())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15304,6 +15311,7 @@
#(e1 e2) #(e1 e2)
#((top) (top)) #((top) (top))
#("i4336" "i4337")) #("i4336" "i4337"))
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15335,6 +15343,7 @@
#(e1 e2) #(e1 e2)
#((top) (top)) #((top) (top))
#("i4336" "i4337")) #("i4336" "i4337"))
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15369,6 +15378,7 @@
#(e1 e2) #(e1 e2)
#((top) (top)) #((top) (top))
#("i4336" "i4337")) #("i4336" "i4337"))
#(ribcage () () ())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15407,6 +15417,10 @@
#((top) (top)) #((top) (top))
#("i4336" #("i4336"
"i4337")) "i4337"))
#(ribcage
()
()
())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15449,6 +15463,10 @@
#((top) (top)) #((top) (top))
#("i4336" #("i4336"
"i4337")) "i4337"))
#(ribcage
()
()
())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -15493,6 +15511,10 @@
(top)) (top))
#("i4336" #("i4336"
"i4337")) "i4337"))
#(ribcage
()
()
())
#(ribcage #(ribcage
#(step) #(step)
#((top)) #((top))
@ -16596,6 +16618,7 @@
#(dy) #(dy)
#((top)) #((top))
#("i4445")) #("i4445"))
#(ribcage () () ())
#(ribcage #(ribcage
#(x y) #(x y)
#((top) (top)) #((top) (top))
@ -16644,6 +16667,7 @@
#(dy) #(dy)
#((top)) #((top))
#("i4445")) #("i4445"))
#(ribcage () () ())
#(ribcage #(ribcage
#(x y) #(x y)
#((top) (top)) #((top) (top))
@ -16688,6 +16712,7 @@
#(dy) #(dy)
#((top)) #((top))
#("i4445")) #("i4445"))
#(ribcage () () ())
#(ribcage #(ribcage
#(x y) #(x y)
#((top) (top)) #((top) (top))
@ -16737,6 +16762,7 @@
#(stuff) #(stuff)
#((top)) #((top))
#("i4454")) #("i4454"))
#(ribcage () () ())
#(ribcage #(ribcage
#(x y) #(x y)
#((top) (top)) #((top) (top))
@ -16785,6 +16811,7 @@
#(stuff) #(stuff)
#((top)) #((top))
#("i4457")) #("i4457"))
#(ribcage () () ())
#(ribcage #(ribcage
#(x y) #(x y)
#((top) (top)) #((top) (top))
@ -16828,6 +16855,7 @@
#(_) #(_)
#((top)) #((top))
#("i4459")) #("i4459"))
#(ribcage () () ())
#(ribcage #(ribcage
#(x y) #(x y)
#((top) (top)) #((top) (top))
@ -16914,6 +16942,7 @@
(cons '#(syntax-object (cons '#(syntax-object
"append" "append"
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(p) #(p)
#((top)) #((top))
@ -16964,6 +16993,7 @@
(cons '#(syntax-object (cons '#(syntax-object
"append" "append"
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(p y) #(p y)
#((top) (top)) #((top) (top))
@ -17142,6 +17172,7 @@
(list '#(syntax-object (list '#(syntax-object
"list->vector" "list->vector"
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(#{\ g4543}#) #(#{\ g4543}#)
#((m4544 top)) #((m4544 top))
@ -17202,6 +17233,7 @@
(cons '#(syntax-object (cons '#(syntax-object
"vector" "vector"
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(#{\ g4516}#) #(#{\ g4516}#)
#((m4517 top)) #((m4517 top))
@ -17301,6 +17333,7 @@
(cons '#(syntax-object (cons '#(syntax-object
list list
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(#{\ g4558}#) #(#{\ g4558}#)
#((m4559 top)) #((m4559 top))
@ -17371,6 +17404,7 @@
(list '#(syntax-object (list '#(syntax-object
cons cons
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(#{\ g4578}# #(#{\ g4578}#
#{\ g4577}#) #{\ g4577}#)
@ -17441,6 +17475,7 @@
(cons '#(syntax-object (cons '#(syntax-object
append append
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(#{\ g4590}#) #(#{\ g4590}#)
#((m4591 top)) #((m4591 top))
@ -17502,6 +17537,7 @@
(cons '#(syntax-object (cons '#(syntax-object
vector vector
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(#{\ g4602}#) #(#{\ g4602}#)
#((m4603 top)) #((m4603 top))
@ -17558,6 +17594,7 @@
(list '#(syntax-object (list '#(syntax-object
list->vector list->vector
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(#{\ g4614}#) #(#{\ g4614}#)
#((m4615 top)) #((m4615 top))
@ -17665,6 +17702,7 @@
(cons '#(syntax-object (cons '#(syntax-object
begin begin
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(exp) #(exp)
#((top)) #((top))
@ -17730,6 +17768,7 @@
(list '#(syntax-object (list '#(syntax-object
include include
((top) ((top)
#(ribcage () () ())
#(ribcage #(fn) #((top)) #("i4671")) #(ribcage #(fn) #((top)) #("i4671"))
#(ribcage () () ()) #(ribcage () () ())
#(ribcage () () ()) #(ribcage () () ())
@ -18092,6 +18131,7 @@
#("i4726" #("i4726"
"i4727" "i4727"
"i4728")) "i4728"))
#(ribcage () () ())
#(ribcage #(ribcage
#(rest) #(rest)
#((top)) #((top))
@ -18126,6 +18166,10 @@
#("i4726" #("i4726"
"i4727" "i4727"
"i4728")) "i4728"))
#(ribcage
()
()
())
#(ribcage #(ribcage
#(rest) #(rest)
#((top)) #((top))
@ -18172,6 +18216,10 @@
#("i4726" #("i4726"
"i4727" "i4727"
"i4728")) "i4728"))
#(ribcage
()
()
())
#(ribcage #(ribcage
#(rest) #(rest)
#((top)) #((top))
@ -18220,6 +18268,10 @@
#("i4726" #("i4726"
"i4727" "i4727"
"i4728")) "i4728"))
#(ribcage
()
()
())
#(ribcage #(ribcage
#(rest) #(rest)
#((top)) #((top))
@ -18270,6 +18322,10 @@
#("i4726" #("i4726"
"i4727" "i4727"
"i4728")) "i4728"))
#(ribcage
()
()
())
#(ribcage #(ribcage
#(rest) #(rest)
#((top)) #((top))
@ -18320,6 +18376,7 @@
(list '#(syntax-object (list '#(syntax-object
let let
((top) ((top)
#(ribcage () () ())
#(ribcage #(body) #((top)) #("i4693")) #(ribcage #(body) #((top)) #("i4693"))
#(ribcage #(ribcage
#(e m1 m2) #(e m1 m2)
@ -18331,6 +18388,7 @@
(list (list '#(syntax-object (list (list '#(syntax-object
t t
((top) ((top)
#(ribcage () () ())
#(ribcage #(ribcage
#(body) #(body)
#((top)) #((top))

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

@ -2632,12 +2632,13 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ () e1 e2 ...) ((_ () e1 e2 ...)
#'(begin e1 e2 ...)) #'(let () e1 e2 ...))
((_ ((out in)) e1 e2 ...) ((_ ((out in)) e1 e2 ...)
#'(syntax-case in () (out (begin e1 e2 ...)))) #'(syntax-case in ()
(out (let () e1 e2 ...))))
((_ ((out in) ...) e1 e2 ...) ((_ ((out in) ...) e1 e2 ...)
#'(syntax-case (list in ...) () #'(syntax-case (list in ...) ()
((out ...) (begin e1 e2 ...))))))) ((out ...) (let () e1 e2 ...)))))))
(define-syntax syntax-rules (define-syntax syntax-rules
(lambda (x) (lambda (x)

7
test-suite/tests/syncase.test
View file

@ -68,6 +68,13 @@
((alist ((key val) ...)) ((alist ((key val) ...))
(list '(key . val) ...)))) (list '(key . val) ...))))
(with-test-prefix "with-syntax"
(pass-if "definitions allowed in body"
(equal? (with-syntax ((a 23))
(define b #'a)
(syntax->datum b))
23)))
(with-test-prefix "tail patterns" (with-test-prefix "tail patterns"
(with-test-prefix "at the outermost level" (with-test-prefix "at the outermost level"
(pass-if "non-tail invocation" (pass-if "non-tail invocation"