diff --git a/collects/scheme/load.ss b/collects/scheme/load.ss index 8794f28170..eb64965370 100644 --- a/collects/scheme/load.ss +++ b/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])) - - diff --git a/collects/slideshow/core.ss b/collects/slideshow/core.ss index 614b20ddcb..dd8e7bc755 100644 --- a/collects/slideshow/core.ss +++ b/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) ""] [(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))] - [sub-items (caddr l)]) + (let* ([rest (let ([p (loop (to-next 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))) diff --git a/collects/syntax/scribblings/strip-context.scrbl b/collects/syntax/scribblings/strip-context.scrbl new file mode 100644 index 0000000000..0953ef514c --- /dev/null +++ b/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.} diff --git a/collects/syntax/scribblings/syntax-object-helpers.scrbl b/collects/syntax/scribblings/syntax-object-helpers.scrbl index ea9c505da2..bff81ea78d 100644 --- a/collects/syntax/scribblings/syntax-object-helpers.scrbl +++ b/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"] diff --git a/collects/syntax/strip-context.ss b/collects/syntax/strip-context.ss index 7e0be69eed..81a3bafc6e 100644 --- a/collects/syntax/strip-context.ss +++ b/collects/syntax/strip-context.ss @@ -1,5 +1,7 @@ #lang scheme/base +(provide strip-context) + (define (strip-context e) (cond [(syntax? e)