suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed bug in nonlinearity-detection

Browse Source 
Improved tracking of module renamings

svn: r4521
This commit is contained in:
Ryan Culpepper 2006-10-08 04:09:11 +00:00
parent 89e2e31af4
commit e0bf9a6e5b
1 changed files with 21 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/macro-debugger/model/hide.ss
View File

@ -798,7 +798,12 @@
(loop (car p) (cons (make-ref pos) rpath)) (loop (car p) (cons (make-ref pos) rpath))
(let ([t (cdr p)]) (let ([t (cdr p)])
(cond [(syntax? t) (cond [(syntax? t)
(loop t (cons (make-tail pos) rpath))] (let ([te (syntax-e t)])
(if (pair? te)
(begin
(table-add! table t (reverse (cons (make-tail pos) rpath)))
(loop-cons te rpath (add1 pos)))
(loop t (cons (make-tail pos) rpath))))]
[(pair? t) [(pair? t)
(loop-cons t rpath (add1 pos))] (loop-cons t rpath (add1 pos))]
[(null? t) [(null? t)
@ -915,6 +920,12 @@
;; wrap-p:rename : syntax (cons syntax syntax) Derivation -> Derivation ;; wrap-p:rename : syntax (cons syntax syntax) Derivation -> Derivation
(define (wrap-p:rename e1 rename deriv) (define (wrap-p:rename e1 rename deriv)
(make-p:rename e1 (deriv-e2 deriv) null rename deriv)) (make-p:rename e1 (deriv-e2 deriv) null rename deriv))
;; wrap/rename-from : syntax Derivation -> Derivation
(define (wrap/rename-from e0 d)
(match d
[(AnyQ deriv (e1 e2))
(rewrap d (make-p:rename e0 e2 null (cons e0 e1) d))]))
;; reconstruct-defval : syntax syntax Derivation -> Derivation ;; reconstruct-defval : syntax syntax Derivation -> Derivation
;; Reconstruct a define-values node from its rhs deriv ;; Reconstruct a define-values node from its rhs deriv
@ -1110,29 +1121,32 @@
(if (positive? count) (if (positive? count)
(match pass1 (match pass1
[(cons (struct mod:prim (head prim)) next) [(cons (struct mod:prim (head prim)) next)
(let ([pass1-part (car pass1)]) (let ([form0 (stx-car forms)]
[pass1-part (car pass1)])
(set! forms (stx-cdr forms)) (set! forms (stx-cdr forms))
(set! pass1 next) (set! pass1 next)
(let ([pass2-part (car (loop2 1))]) (let ([pass2-part (car (loop2 1))])
(cons (combine-prim pass1-part pass2-part) (cons (wrap/rename-from form0 (combine-prim pass1-part pass2-part))
(loop (sub1 count)))))] (loop (sub1 count)))))]
[(cons (struct mod:splice (head tail)) next) [(cons (struct mod:splice (head tail)) next)
(let ([pass1-part (car pass1)] (let ([form0 (stx-car forms)]
[pass1-part (car pass1)]
[inner-n (- (length (stx->list tail)) [inner-n (- (length (stx->list tail))
(length (stx->list (stx-cdr forms))))]) (length (stx->list (stx-cdr forms))))])
(set! forms tail) (set! forms tail)
(set! pass1 next) (set! pass1 next)
(let ([inners (loop inner-n)]) (let ([inners (loop inner-n)])
(cons (combine-begin head inners) (cons (wrap/rename-from form0 (combine-begin head inners))
(loop (sub1 count)))))] (loop (sub1 count)))))]
[(cons (struct mod:lift (head tail)) next) [(cons (struct mod:lift (head tail)) next)
(let ([inner-n (length (stx->list tail))]) (let ([form0 (stx-car forms)]
[inner-n (length (stx->list tail))])
(set! forms (stx-cdr forms)) (set! forms (stx-cdr forms))
(set! pass1 next) (set! pass1 next)
(let ([inners (loop inner-n)]) (let ([inners (loop inner-n)])
(set! forms (cons (deriv-e2 head) forms)) (set! forms (cons (deriv-e2 head) forms))
(let ([finish (car (loop 1))]) (let ([finish (car (loop 1))])
(cons (combine-lifts head finish inners) (cons (wrap/rename-from form0 (combine-lifts head finish inners))
(loop (sub1 count))))))] (loop (sub1 count))))))]
['() ['()
#;(printf "module-begin->lderiv:loop: unexpected null~n") #;(printf "module-begin->lderiv:loop: unexpected null~n")