fix and document syntax/strip-context
svn: r13847
This commit is contained in:
parent
50dff6234c
commit
f0473137e6
|
@ -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]))
|
||||
|
||||
|
||||
|
|
|
@ -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)))
|
||||
|
|
12
collects/syntax/scribblings/strip-context.scrbl
Normal file
12
collects/syntax/scribblings/strip-context.scrbl
Normal 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.}
|
|
@ -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"]
|
||||
|
||||
|
|
|
@ -1,5 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide strip-context)
|
||||
|
||||
(define (strip-context e)
|
||||
(cond
|
||||
[(syntax? e)
|
||||
|
|
Loading…
Reference in New Issue
Block a user