fix and document syntax/strip-context

svn: r13847

collects/scheme/load.ss

@@ -1,4 +1,5 @@
 #lang scheme
+(require syntax/strip-context)
 
 (provide (rename-out [module-begin #%module-begin]
                      [top-interaction #%top-interaction]))
@@ -40,24 +41,3 @@
         (lambda ()
           (set! namespace (current-namespace))
           (current-namespace ns)))))
-
-(define (strip-context e)
-  (cond
-   [(syntax? e)
-    (datum->syntax #f
-                   (strip-context (syntax-e e))
-                   e
-                   e)]
-   [(pair? e) (cons (strip-context (car e))
-                    (strip-context (cdr e)))]
-   [(vector? e) (list->vector
-                 (map strip-context
-                      (vector->list e)))]
-   [(box? e) (box (strip-context (unbox e)))]
-   [(prefab-struct-key e)
-    => (lambda (k)
-         (apply make-prefab-struct
-                (strip-context (cdr (vector->list (struct->vector e))))))]
-   [else e]))
-
-

collects/slideshow/core.ss

@@ -561,6 +561,11 @@
 	(define ah (arrowhead gap-size 0))
 	(define current-item (colorize (hc-append (- (/ gap-size 2)) ah ah) blue))
 	(define other-item (rc-superimpose (ghost current-item) (colorize ah "light gray")))
+        (define (to-next l)
+          (let ([l (cdddr l)])
+            (if (and (pair? l) (number? (car l)))
+                (cdr l)
+                l)))
 	(lambda (which)
 	  (slide/name
 	   (format "--~a--"
@@ -569,7 +574,7 @@
 		      [(null? l) "<unknown>"]
 		      [(eq? (car l) which)
 		       (cadr l)]
-		      [else (loop (cdddr l))])))
+		      [else (loop (to-next l))])))
 	   (blank (+ title-h gap-size))
 	   (lc-superimpose
 	    (blank (current-para-width) 0)
@@ -581,7 +586,7 @@
 				    (and (list? (car l))
 					 (memq which (car l))))])
 		  (vc-append
-		   gap-size
+                   gap-size
 		   (page-para
 		    (hbl-append
 		     (quotient gap-size 2)
@@ -592,8 +597,12 @@
 		       (if (pict? p)
 			   p
 			   (bt p)))))
-		   (let ([rest (loop (cdddr l))]
+		   (let* ([rest (let ([p (loop (to-next l))]
-			 [sub-items (caddr l)])
+                                      [l (cdddr l)])
+                                  (if (and (pair? l) (number? (car l)))
+                                      (inset p 0 (car l) 0 0)
+                                      p))]
+                          [sub-items (caddr l)])
 		     (if (and current?
 			      sub-items
 			      (not (null? sub-items)))

collects/syntax/scribblings/strip-context.scrbl

@@ -0,0 +1,12 @@
+#lang scribble/doc
+@(require "common.ss"
+          (for-label syntax/strip-context))
+
+@title[#:tag "strip-context"]{Stripping Lexical Context}
+
+@defmodule[syntax/strip-context]
+
+@defproc[(strip-context [stx syntax?]) syntax?]{
+
+Removes all lexical context from @scheme[stx], preserving
+source-location information and properties.}

collects/syntax/scribblings/syntax-object-helpers.scrbl

@@ -8,5 +8,6 @@
 @include-section["boundmap.scrbl"]
 @include-section["to-string.scrbl"]
 @include-section["free-vars.scrbl"]
+@include-section["strip-context.scrbl"]
 @include-section["zodiac.scrbl"]
 

collects/syntax/strip-context.ss

@@ -1,5 +1,7 @@
 #lang scheme/base
 
+(provide strip-context)
+
 (define (strip-context e)
   (cond
    [(syntax? e)