commit caf5421f7f7e3598f315bf73573310290749e977 parent 7bef14c014a25e351ec443ac7ffb2dfb602d54bf Author: Matthew Flatt <mflatt@racket-lang.org> Date: Thu, 26 Feb 2009 22:00:25 +0000 fix scribble/lp for check syntax svn: r13858 original commit: a4078d52950e3619911e12483ad3e70c70990663 Diffstat:
| M | collects/scribble/lp/lang/lang.ss | | | 38 | +++++++++++++++++++++----------------- |
1 file changed, 21 insertions(+), 17 deletions(-)
diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss @@ -31,23 +31,27 @@ (define stupid-internal-definition-sytnax (unless first-id (raise-syntax-error 'scribble/lp "no chunks"))) + (define orig-stx (syntax-case stx () [(_ orig) #'orig])) + (define (restore nstx d) (datum->syntax orig-stx d nstx nstx)) + (define (shift nstx) (datum->syntax orig-stx (syntax-e nstx) nstx nstx)) (define body - (let loop ([block (if main-id - (get-chunk main-id) - (get-chunk first-id))]) - (append-map - (lambda (expr) - (if (identifier? expr) - (let ([subs (get-chunk expr)]) - (if (pair? subs) - (begin (set! chunk-mentions (cons expr chunk-mentions)) - (loop subs)) - (list expr))) - (let ([subs (syntax->list expr)]) - (if subs - (list (loop subs)) - (list expr))))) - block))) + (let ([main-id (or main-id first-id)]) + (restore + main-id + (let loop ([block (get-chunk main-id)]) + (append-map + (lambda (expr) + (if (identifier? expr) + (let ([subs (get-chunk expr)]) + (if (pair? subs) + (begin (set! chunk-mentions (cons expr chunk-mentions)) + (loop subs)) + (list (shift expr)))) + (let ([subs (syntax->list expr)]) + (if subs + (list (restore expr (loop subs))) + (list (shift expr)))))) + block))))) (with-syntax ([(body ...) body] ;; construct arrows manually [((b-use b-id) ...) @@ -82,4 +86,4 @@ (syntax-case expanded () [(module name lang (mb . stuff)) (begin (extract-chunks #'stuff) - #'(#%module-begin (tangle)))]))])) + #'(#%module-begin (tangle id)))]))]))