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
(kernel:kernel-syntax-case stx #f
; cond :
[(if test (begin then) else-stx)
(let ([origin (syntax-property stx 'origin)]
[rebuild-if
(lambda (new-cond-test)
(let* ([new-then (recur-regular (syntax then))]
[rebuilt (stepper-syntax-property
(rebuild-stx `(if ,(recur-regular (syntax test))
,new-then
,(recur-in-cond (syntax else-stx) new-cond-test))
stx)
'stepper-hint
'comes-from-cond)])
; move the stepper-else mark to the if, if it's present:
(if (stepper-syntax-property (syntax test) 'stepper-else)
(stepper-syntax-property rebuilt 'stepper-else #t)
rebuilt)))])
(cond [(cond-test stx) ; continuing an existing 'cond'
(rebuild-if cond-test)]
[(and origin (pair? origin) (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond'
(rebuild-if (lambda (test-stx)
(and (eq? (syntax-source stx) (syntax-source test-stx))
(eq? (syntax-position stx) (syntax-position test-stx)))))]
[else ; not from a 'cond' at all.
(rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))]
[(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL
(cond-test stx)
(stepper-syntax-property stx 'stepper-skip-completely #t)]
(kernel:kernel-syntax-case
stx
#f
; cond :
[(#%if test (#%let () then) else-stx)
(let ([origin (syntax-property stx 'origin)]
[rebuild-if
(lambda (new-cond-test)
(let* ([new-then (recur-regular (syntax then))]
[rebuilt (stepper-syntax-property
(rebuild-stx `(if ,(recur-regular (syntax test))
,new-then
,(recur-in-cond (syntax else-stx) new-cond-test))
stx)
'stepper-hint
'comes-from-cond)])
; move the stepper-else mark to the if, if it's present:
(if (stepper-syntax-property (syntax test) 'stepper-else)
(stepper-syntax-property rebuilt 'stepper-else #t)
rebuilt)))])
(cond [(cond-test stx) ; continuing an existing 'cond'
(rebuild-if cond-test)]
[(and origin (pair? origin) (eq? (syntax-e (car origin)) 'cond)) ; starting a new 'cond'
(rebuild-if (lambda (test-stx)
(and (eq? (syntax-source stx) (syntax-source test-stx))
(eq? (syntax-position stx) (syntax-position test-stx)))))]
[else ; not from a 'cond' at all.
(rebuild-stx `(if ,@(map recur-regular (list (syntax test) (syntax (begin then)) (syntax else-stx)))) stx)]))]
[(begin body) ; else clauses of conds; ALWAYS AN ERROR CALL
(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
; 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))
(eq? 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
;; language-inserted else clause
[(if test result)
@ -254,7 +254,7 @@
(loop (syntax else-clause)))]
;; else clause appears momentarily in 'before,' even
;; though it's a 'skip-completely'
[(begin . rest) null]
[(let-values () . rest) null]
[else-stx
(error 'unwind-cond
"expected an if, got: ~.s"

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

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