fix scribble/lp for check syntax

svn: r13858

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
+    (let ([main-id (or main-id first-id)])
-                          (get-chunk main-id)
+      (restore
-                          (get-chunk first-id))])
+       main-id
-      (append-map
+       (let loop ([block (get-chunk main-id)])
-       (lambda (expr)
+         (append-map
-         (if (identifier? expr)
+          (lambda (expr)
-           (let ([subs (get-chunk expr)])
+            (if (identifier? expr)
-             (if (pair? subs)
+                (let ([subs (get-chunk expr)])
-               (begin (set! chunk-mentions (cons expr chunk-mentions))
+                  (if (pair? subs)
-                      (loop subs))
+                      (begin (set! chunk-mentions (cons expr chunk-mentions))
-               (list expr)))
+                             (loop subs))
-           (let ([subs (syntax->list expr)])
+                      (list (shift expr))))
-             (if subs
+                (let ([subs (syntax->list expr)])
-               (list (loop subs))
+                  (if subs
-               (list expr)))))
+                      (list (restore expr (loop subs)))
-       block)))
+                      (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)))]))]))