diff --git a/scheme/last-revision b/scheme/last-revision index 8f9574f..86fc8f4 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1861 +1862 diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index d2010e8..ca9e674 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -380,6 +380,11 @@ ;;; Notice that both sx and sy would be shift marks. (define join-wraps (lambda (m1* s1* ae1* e) + (define merge-ae* + (lambda (ls1 ls2) + (if (and (pair? ls1) (pair? ls2) (not (car ls2))) + (cancel ls1 ls2) + (append ls1 ls2)))) (define cancel (lambda (ls1 ls2) (let f ((x (car ls1)) (ls1 (cdr ls1))) @@ -393,15 +398,15 @@ (not (null? m2*)) (anti-mark? (car m2*))) ; cancel mark, anti-mark, and corresponding shifts - (values (cancel m1* m2*) (cancel s1* s2*) (cancel ae1* ae2*)) - (values (append m1* m2*) (append s1* s2*) (append ae1* ae2*)))))) + (values (cancel m1* m2*) (cancel s1* s2*) (merge-ae* ae1* ae2*)) + (values (append m1* m2*) (append s1* s2*) (merge-ae* ae1* ae2*)))))) ;;; The procedure mkstx is then the proper constructor for ;;; wrapped syntax objects. It takes a syntax object, a list ;;; of marks, and a list of substs. It joins the two wraps ;;; making sure that marks and anti-marks and corresponding ;;; shifts cancel properly. - (define mkstx ;;; QUEUE + (define mkstx (lambda (e m* s* ae*) (if (and (stx? e) (not (top-marked? m*))) (let-values (((m* s* ae*) (join-wraps m* s* ae* e))) @@ -4075,7 +4080,6 @@ ((annotation? x) (make-trace (make-stx x '() '() '()))) (else (condition))))) - (define syntax-violation* (lambda (who msg form condition-object)