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

Add `stepper-skipto/discard' property.

Browse Source 
Like stepper-skipto, but discards the context.  This is for the
contracts implementation in the DMdA teaching languages.

svn: r12078
This commit is contained in:
Mike Sperber 2008-10-21 07:06:48 +00:00
parent e2d4bc0d2b
commit f26fcdd82c
3 changed files with 31 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/stepper/internal-docs.txt
View File

@ -202,6 +202,16 @@ Where it's used: the stepper-skipto label is used by the 2nd-pass
macro-labeler and the annotator. Both are in annotate.ss. In addition macro-labeler and the annotator. Both are in annotate.ss. In addition
to skipping inward, a stepper hint to skipping inward, a stepper hint
stepper-skipto/discard :
This is like stepper-skipto, except that it makes the stepper
replace the expression the property is attached to by the
subexpression indicated by its value.
(This is used in the contracts implementation for "Die Macht der
Abstraktion", where procedures are wrapped in a contract-checking
context that has no impact on the reduction semantics.)
stepper-else : stepper-else :
[ #t ] : Initially applied to the 'true' that the cond macro [ #t ] : Initially applied to the 'true' that the cond macro
replaces a beginner's 'else' with, it is later transferred replaces a beginner's 'else' with, it is later transferred

14
collects/stepper/private/annotate.ss
View File

@ -387,13 +387,17 @@
. -> . (vector/p syntax? binding-set?)) . -> . (vector/p syntax? binding-set?))
(lambda (exp tail-bound pre-break? procedure-name-info) (lambda (exp tail-bound pre-break? procedure-name-info)
(cond [(stepper-syntax-property exp 'stepper-skipto) (cond [(cond
((stepper-syntax-property exp 'stepper-skipto) 'rebuild)
((stepper-syntax-property exp 'stepper-skipto/discard) 'discard)
(else #f))
=> (lambda (traversal)
(let* ([free-vars-captured #f] ; this will be set!'ed (let* ([free-vars-captured #f] ; this will be set!'ed
;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))] ;;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))]
; WARNING! I depend on the order of evaluation in application arguments here: ;; WARNING! I depend on the order of evaluation in application arguments here:
[annotated (skipto/auto [annotated (skipto/auto
exp exp
'rebuild traversal
(lambda (subterm) (lambda (subterm)
(let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)]) (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
(set! free-vars-captured free-vars) (set! free-vars-captured free-vars)
@ -401,7 +405,7 @@
(2vals (wcm-wrap (2vals (wcm-wrap
skipto-mark skipto-mark
annotated) annotated)
free-vars-captured))] free-vars-captured)))]
[(stepper-syntax-property exp 'stepper-skip-completely) [(stepper-syntax-property exp 'stepper-skip-completely)
(2vals (wcm-wrap 13 exp) null)] (2vals (wcm-wrap 13 exp) null)]

3
collects/stepper/private/shared.ss
View File

@ -481,7 +481,8 @@
;; traversal argument is 'discard, the result of the transformation is the ;; traversal argument is 'discard, the result of the transformation is the
;; result of this function ;; result of this function
(define (skipto/auto stx traversal transformer) (define (skipto/auto stx traversal transformer)
(cond [(stepper-syntax-property stx 'stepper-skipto) (cond [(or (stepper-syntax-property stx 'stepper-skipto)
(stepper-syntax-property stx 'stepper-skipto/discard))
=> =>
(cut update <> stx (cut skipto/auto <> traversal transformer) traversal)] (cut update <> stx (cut skipto/auto <> traversal transformer) traversal)]
[else (transformer stx)])) [else (transformer stx)]))