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

may have fixed cond in stepper tests

Browse Source 
(cherry picked from commit 60dabc8ad7)
This commit is contained in:
John Clements 2010-10-19 17:45:43 -07:00 committed by Ryan Culpepper
parent 5f7993c6db
commit c05b501f1b
3 changed files with 34 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/stepper/private/annotate.rkt
View File

@ -146,36 +146,37 @@
[rewritten [rewritten
(kernel:kernel-syntax-case stx #f (kernel:kernel-syntax-case
stx
; cond : #f
[(if test (begin then) else-stx) ; cond :
(let ([origin (syntax-property stx 'origin)] [(#%if test (#%let () then) else-stx)
[rebuild-if (let ([origin (syntax-property stx 'origin)]
(lambda (new-cond-test) [rebuild-if
(let* ([new-then (recur-regular (syntax then))] (lambda (new-cond-test)
[rebuilt (stepper-syntax-property (let* ([new-then (recur-regular (syntax then))]
(rebuild-stx `(if ,(recur-regular (syntax test)) [rebuilt (stepper-syntax-property
,new-then (rebuild-stx `(if ,(recur-regular (syntax test))
,(recur-in-cond (syntax else-stx) new-cond-test)) ,new-then
stx) ,(recur-in-cond (syntax else-stx) new-cond-test))
'stepper-hint stx)
'comes-from-cond)]) 'stepper-hint
; move the stepper-else mark to the if, if it's present: 'comes-from-cond)])
(if (stepper-syntax-property (syntax test) 'stepper-else) ; move the stepper-else mark to the if, if it's present:
(stepper-syntax-property rebuilt 'stepper-else #t) (if (stepper-syntax-property (syntax test) 'stepper-else)
rebuilt)))]) (stepper-syntax-property rebuilt 'stepper-else #t)
(cond [(cond-test stx) ; continuing an existing 'cond' rebuilt)))])
(rebuild-if cond-test)] (cond [(cond-test stx) ; continuing an existing 'cond'
[(and origin (pair? origin) (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond' (rebuild-if cond-test)]
(rebuild-if (lambda (test-stx) [(and origin (pair? origin) (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond'
(and (eq? (syntax-source stx) (syntax-source test-stx)) (rebuild-if (lambda (test-stx)
(eq? (syntax-position stx) (syntax-position test-stx)))))] (and (eq? (syntax-source stx) (syntax-source test-stx))
[else ; not from a 'cond' at all. (eq? (syntax-position stx) (syntax-position test-stx)))))]
(rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))] [else ; not from a 'cond' at all.
[(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL (rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))]
(cond-test stx) [(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL
(stepper-syntax-property stx 'stepper-skip-completely #t)] (cond-test stx)
(stepper-syntax-property stx 'stepper-skip-completely #t)]
; wrapper on a local. This is necessary because teach.ss expands local into a trivial let wrapping a bunch of ; wrapper on a local. This is necessary because teach.ss expands local into a trivial let wrapping a bunch of
; internal defines, and therefore the letrec-values on which I want to hang the 'stepper-hint doesn't yet ; internal defines, and therefore the letrec-values on which I want to hang the 'stepper-hint doesn't yet

4
collects/stepper/private/macro-unwind.rkt
View File

@ -244,7 +244,7 @@
(syntax-property stx 'user-source)) (syntax-property stx 'user-source))
(eq? user-position (eq? user-position
(syntax-property stx 'user-position))) (syntax-property stx 'user-position)))
(syntax-case stx (if begin) (syntax-case stx (if begin let-values)
;; the else clause disappears when it's a ;; the else clause disappears when it's a
;; language-inserted else clause ;; language-inserted else clause
[(if test result) [(if test result)
@ -254,7 +254,7 @@
(loop (syntax else-clause)))] (loop (syntax else-clause)))]
;; else clause appears momentarily in 'before,' even ;; else clause appears momentarily in 'before,' even
;; though it's a 'skip-completely' ;; though it's a 'skip-completely'
[(begin . rest) null] [(let-values () . rest) null]
[else-stx [else-stx
(error 'unwind-cond (error 'unwind-cond
"expected an if, got: ~.s" "expected an if, got: ~.s"

3
collects/stepper/private/reconstruct.rkt
View File

@ -13,8 +13,7 @@
"model-settings.ss" "model-settings.ss"
"shared.ss" "shared.ss"
"my-macros.ss" "my-macros.ss"
(for-syntax scheme/base) (for-syntax scheme/base))
#;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss"))
(provide/contract (provide/contract
[reconstruct-completed (syntax? [reconstruct-completed (syntax?