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 ...) (with-syntax ([(mapped-entries ...)
(map (map
(lookup (lookup
(car (syntax->datum #'orig*)) (syntax->datum #'orig*)
#'(name* ...)) #'(name* ...))
#'(entries ...))]) #'(entries ...))])
#'(begin #'(begin
@ -96,8 +96,7 @@
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
[(_ definer next fail [name* (arg** ...) clause** ...] ...) [(_ definer next fail [name* (arg** ...) clause** ...] ...)
(with-syntax ([orig* (with-syntax ([orig* (datum->syntax #'foo #'(name* ...))])
(datum->syntax #'foo (list #'(name* ...)))])
#'(define-syntax definer #'(define-syntax definer
(syntax-rules () (syntax-rules ()
[(_ config (entries (... ...))) [(_ 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)))))) (and rest (cons first rest))))))
((null? e) '()) ((null? e) '())
((stx? e) ((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e))) (and (not (top-marked? m*))
(match-each (stx-expr e) p m* s* ae*))) (let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each (stx-expr e) p m* s* ae*))))
[(annotation? e) [(annotation? e)
(match-each (annotation-expression e) p m* s* ae*)] (match-each (annotation-expression e) p m* s* ae*)]
(else #f)))) (else #f))))
@ -2193,8 +2194,10 @@
(match (car e) (car y-pat) m* s* ae* r))) (match (car e) (car y-pat) m* s* ae* r)))
(values #f #f #f)))) (values #f #f #f))))
((stx? e) ((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e))) (if (top-marked? m*)
(f (stx-expr e) m* s* ae*))) (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) [(annotation? e)
(f (annotation-expression e) m* s* ae*)] (f (annotation-expression e) m* s* ae*)]
(else (values '() y-pat (match e z-pat m* s* ae* r))))))) (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)))) (and l (cons (stx^ (car e) m* s* ae*) l))))
((null? e) '()) ((null? e) '())
((stx? e) ((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e))) (and (not (top-marked? m*))
(match-each-any (stx-expr e) m* s* ae*))) (let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match-each-any (stx-expr e) m* s* ae*))))
[(annotation? e) [(annotation? e)
(match-each-any (annotation-expression e) m* s* ae*)] (match-each-any (annotation-expression e) m* s* ae*)]
(else #f)))) (else #f))))
@ -2279,8 +2283,9 @@
((eq? p '_) r) ((eq? p '_) r)
((eq? p 'any) (cons (stx^ e m* s* ae*) r)) ((eq? p 'any) (cons (stx^ e m* s* ae*) r))
((stx? e) ((stx? e)
(let-values (((m* s* ae*) (join-wraps m* s* ae* e))) (and (not (top-marked? m*))
(match (stx-expr e) p m* s* ae* r))) (let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
(match (stx-expr e) p m* s* ae* r))))
[(annotation? e) [(annotation? e)
(match (annotation-expression e) p m* s* ae* r)] (match (annotation-expression e) p m* s* ae* r)]
(else (match* e p m* s* ae* r))))) (else (match* e p m* s* ae* r)))))