conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixed minor bug in syntax-case where the wraps and marks of 

top-marked wrapped syntax objects were incorrectly combined.
E.g., it used to be that:

  (syntax-case (datum->syntax #'foo #'(x y)) ()
    [(x y) 'shouldntmatch] [_ 'ok])

yields shouldntmatch; it's now ok.
This commit is contained in:
Abdulaziz Ghuloum 2008-06-10 12:35:56 -07:00
parent ef50e9f515
commit fe1f7077ff
4 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

5
scheme/ikarus.string-to-number.ss
View File

@ -81,7 +81,7 @@
(with-syntax ([(mapped-entries ...)
(map
(lookup
(car (syntax->datum #'orig*))
(syntax->datum #'orig*)
#'(name* ...))
#'(entries ...))])
#'(begin
@ -96,8 +96,7 @@
(lambda (x)
(syntax-case x ()
[(_ definer next fail [name* (arg** ...) clause** ...] ...)
(with-syntax ([orig*
(datum->syntax #'foo (list #'(name* ...)))])
(with-syntax ([orig* (datum->syntax #'foo #'(name* ...))])
#'(define-syntax definer
(syntax-rules ()
[(_ config (entries (... ...)))

2
scheme/last-revision
View File

@ -1 +1 @@
1509
1510

21
scheme/psyntax.expander.ss
View File

@ -2170,8 +2170,9 @@
(and rest (cons first rest))))))
((null? e) '())
((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each (stx-expr e) p m* s* ae*)))
(and (not (top-marked? m*))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each (stx-expr e) p m* s* ae*))))
[(annotation? e)
(match-each (annotation-expression e) p m* s* ae*)]
(else #f))))
@ -2193,8 +2194,10 @@
(match (car e) (car y-pat) m* s* ae* r)))
(values #f #f #f))))
((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(f (stx-expr e) m* s* ae*)))
(if (top-marked? m*)
(values '() y-pat (match e z-pat m* s* ae* r))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(f (stx-expr e) m* s* ae*))))
[(annotation? e)
(f (annotation-expression e) m* s* ae*)]
(else (values '() y-pat (match e z-pat m* s* ae* r)))))))
@ -2206,8 +2209,9 @@
(and l (cons (stx^ (car e) m* s* ae*) l))))
((null? e) '())
((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each-any (stx-expr e) m* s* ae*)))
(and (not (top-marked? m*))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each-any (stx-expr e) m* s* ae*))))
[(annotation? e)
(match-each-any (annotation-expression e) m* s* ae*)]
(else #f))))
@ -2279,8 +2283,9 @@
((eq? p '_) r)
((eq? p 'any) (cons (stx^ e m* s* ae*) r))
((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match (stx-expr e) p m* s* ae* r)))
(and (not (top-marked? m*))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match (stx-expr e) p m* s* ae* r))))
[(annotation? e)
(match (annotation-expression e) p m* s* ae* r)]
(else (match* e p m* s* ae* r)))))