From f26fcdd82c1efa40fce0ea76cb562f6377c86d76 Mon Sep 17 00:00:00 2001
From: Mike Sperber <sperber@deinprogramm.de>
Date: Tue, 21 Oct 2008 07:06:48 +0000
Subject: [PATCH] Add `stepper-skipto/discard' property.

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

svn: r12078
---
 collects/stepper/internal-docs.txt   | 10 ++++++++
 collects/stepper/private/annotate.ss | 34 ++++++++++++++++------------
 collects/stepper/private/shared.ss   |  3 ++-
 3 files changed, 31 insertions(+), 16 deletions(-)

diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt
index f47d9be621..fefbd85372 100644
--- a/collects/stepper/internal-docs.txt
+++ b/collects/stepper/internal-docs.txt
@@ -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
 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 :
  [ #t ] : Initially applied to the 'true' that the cond macro
   replaces a beginner's 'else' with, it is later transferred
diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss
index 5a2a69a785..8107300a0e 100644
--- a/collects/stepper/private/annotate.ss
+++ b/collects/stepper/private/annotate.ss
@@ -387,21 +387,25 @@
                . -> . (vector/p syntax? binding-set?))
     (lambda (exp tail-bound pre-break? procedure-name-info)
       
-      (cond [(stepper-syntax-property exp 'stepper-skipto)
-             (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))]
-                    ; WARNING! I depend on the order of evaluation in application arguments here:
-                    [annotated (skipto/auto
-                                exp
-                                'rebuild
-                                (lambda (subterm)
-                                  (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
-                                              (set! free-vars-captured free-vars)
-                                              stx)))])
-               (2vals (wcm-wrap
-                       skipto-mark
-                       annotated)
-                      free-vars-captured))]
+      (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
+			 ;;[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:
+			 [annotated (skipto/auto
+				     exp
+				     traversal
+				     (lambda (subterm)
+				       (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)])
+						   (set! free-vars-captured free-vars)
+						   stx)))])
+		    (2vals (wcm-wrap
+			    skipto-mark
+			    annotated)
+			   free-vars-captured)))]
             
             [(stepper-syntax-property exp 'stepper-skip-completely)
              (2vals (wcm-wrap 13 exp) null)]
diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss
index 59b55eeb08..208f50393e 100644
--- a/collects/stepper/private/shared.ss
+++ b/collects/stepper/private/shared.ss
@@ -481,7 +481,8 @@
   ;; traversal argument is 'discard, the result of the transformation is the
   ;; result of this function
   (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)]
           [else (transformer stx)]))