fix and document syntax/strip-context

svn: r13847
This commit is contained in:
Matthew Flatt 2009-02-26 13:19:25 +00:00
parent 50dff6234c
commit f0473137e6
5 changed files with 29 additions and 25 deletions

View File

@ -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]))

View File

@ -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))]
[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)))

View File

@ -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.}

View File

@ -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"]

View File

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