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

annotation-expressions are now tracked independently of marks and 

shifts.
This commit is contained in:
Abdulaziz Ghuloum 2009-10-19 21:28:00 +03:00
parent 5a2de815cb
commit 444aa9bbf0
2 changed files with 9 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1861 1862

12
scheme/psyntax.expander.ss
View File

@ -380,6 +380,11 @@
;;; Notice that both sx and sy would be shift marks. ;;; Notice that both sx and sy would be shift marks.
(define join-wraps (define join-wraps
(lambda (m1* s1* ae1* e) (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 (define cancel
(lambda (ls1 ls2) (lambda (ls1 ls2)
(let f ((x (car ls1)) (ls1 (cdr ls1))) (let f ((x (car ls1)) (ls1 (cdr ls1)))
@ -393,15 +398,15 @@
(not (null? m2*)) (not (null? m2*))
(anti-mark? (car m2*))) (anti-mark? (car m2*)))
; cancel mark, anti-mark, and corresponding shifts ; cancel mark, anti-mark, and corresponding shifts
(values (cancel m1* m2*) (cancel s1* s2*) (cancel ae1* ae2*)) (values (cancel m1* m2*) (cancel s1* s2*) (merge-ae* ae1* ae2*))
(values (append m1* m2*) (append s1* s2*) (append ae1* ae2*)))))) (values (append m1* m2*) (append s1* s2*) (merge-ae* ae1* ae2*))))))
;;; The procedure mkstx is then the proper constructor for ;;; The procedure mkstx is then the proper constructor for
;;; wrapped syntax objects. It takes a syntax object, a list ;;; wrapped syntax objects. It takes a syntax object, a list
;;; of marks, and a list of substs. It joins the two wraps ;;; of marks, and a list of substs. It joins the two wraps
;;; making sure that marks and anti-marks and corresponding ;;; making sure that marks and anti-marks and corresponding
;;; shifts cancel properly. ;;; shifts cancel properly.
(define mkstx ;;; QUEUE (define mkstx
(lambda (e m* s* ae*) (lambda (e m* s* ae*)
(if (and (stx? e) (not (top-marked? m*))) (if (and (stx? e) (not (top-marked? m*)))
(let-values (((m* s* ae*) (join-wraps m* s* ae* e))) (let-values (((m* s* ae*) (join-wraps m* s* ae* e)))
@ -4075,7 +4080,6 @@
((annotation? x) ((annotation? x)
(make-trace (make-stx x '() '() '()))) (make-trace (make-stx x '() '() '())))
(else (condition))))) (else (condition)))))
(define syntax-violation* (define syntax-violation*
(lambda (who msg form condition-object) (lambda (who msg form condition-object)