Redex: added to-lw/stx

plus improved the redex docs slightly and Rackety
This commit is contained in:
Robby Findler 2011-05-30 08:10:20 -05:00
parent fbbb30f7b0
commit b43e956c7b
4 changed files with 43 additions and 6 deletions

View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require scheme/contract
(require racket/contract
"private/pict.ss"
"private/core-layout.ss"
"private/loc-wrapper.ss"
@ -108,8 +108,32 @@
lw-column-span)
(provide to-lw
to-lw/stx
(struct-out lw))
(require (prefix-in lw/ct: "private/loc-wrapper-ct.rkt")
(prefix-in lw/rt: "private/loc-wrapper-rt.rkt"))
(define (to-lw/stx stx)
(let loop ([stx (lw/ct:to-lw/proc stx)])
(syntax-case stx (init-loc-wrapper make-lw add-spans list quote)
[(make-lw arg ...)
(apply make-lw (map loop (syntax->list #'(arg ...))))]
[(init-loc-wrapper arg ...)
(apply lw/rt:init-loc-wrapper (map loop (syntax->list #'(arg ...))))]
[(add-spans arg ...)
(apply lw/rt:add-spans (map loop (syntax->list #'(arg ...))))]
[(list arg ...)
(apply list (map loop (syntax->list #'(arg ...))))]
[(quote arg)
(syntax->datum #'arg)]
[_
(let ([x (syntax-e stx)])
(unless (or (number? x)
(string? x)
(boolean? x))
(error 'to-lw/stx "unk thing: ~s\n" (syntax->datum stx)))
x)])))
(provide/contract
[just-before (-> (or/c pict? string? symbol?) lw? lw?)]
[just-after (-> (or/c pict? string? symbol?) lw? lw?)])

View File

@ -67,7 +67,8 @@
#,quoted?)]
[x
(and (identifier? #'x)
(or (term-fn? (syntax-local-value #'x (λ () #f)))
(or (and (syntax-transforming?)
(term-fn? (syntax-local-value #'x (λ () #f))))
((is-term-fn?) #'x)))
#`(make-lw
'#,(syntax-e #'x)

View File

@ -339,7 +339,8 @@ bound to @racket['()].
If @racket[redex-match] receives three arguments, it
matches the pattern (in the language) against its third
argument. If it matches, this returns a list of match
structures describing the matches. If it fails, it returns
structures describing the matches (see @racket[match?] and
@racket[match-bindings]). If it fails, it returns
@racket[#f].
If @racket[redex-match] receives only two arguments, it
@ -2589,6 +2590,13 @@ the empty string and the @racket[x] in the typeset output.
}
@defproc[(to-lw/stx [stx syntax?]) lw?]{
This is the runtime variant on @racket[to-lw]; it accepts a
syntax object and returns the corresponding @racket[lw] structs.
It only uses the location information in the syntax object,
so metafunctions will not be rendered properly.
}
@defproc[(render-lw (language/nts (or/c (listof symbol?) compiled-lang?))
(lw lw?)) pict?]{

View File

@ -49,10 +49,11 @@
;
(module lw-test mzscheme
(module lw-test racket/base
(require "test-util.ss"
"../private/loc-wrapper.ss"
"lw-test-util.ss")
"lw-test-util.ss"
(only-in "../pict.rkt" to-lw/stx))
(reset-count)
@ -286,5 +287,8 @@
#t #f))
0 0 0 3))
(test (normalize-lw (to-lw (a ((b)) c 1 #t)))
(normalize-lw (to-lw/stx #'(a ((b)) c 1 #t))))
(print-tests-passed "lw-test.ss"))