source information for the interpreter

* module/ice-9/psyntax.scm: Try to propagate source information when
  generating output for the interpreter.

* module/ice-9/psyntax-pp.scm: Regenerate.

module/ice-9/psyntax.scm

@@ -337,39 +337,46 @@
 )
 
 
+(define (decorate-source e s)
+  (if (and (pair? e) s)
+      (set-source-properties! e s))
+  e)
+
 ;;; output constructors
 (define build-void
   (lambda (source)
     (case (fluid-ref *mode*)
       ((c) ((@ (language tree-il) make-void) source))
-      (else '(if #f #f)))))
+      (else (decorate-source '(if #f #f) source)))))
 
 (define build-application
   (lambda (source fun-exp arg-exps)
     (case (fluid-ref *mode*)
       ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps))
-      (else `(,fun-exp . ,arg-exps)))))
+      (else (decorate-source `(,fun-exp . ,arg-exps) source)))))
 
 (define build-conditional
   (lambda (source test-exp then-exp else-exp)
     (case (fluid-ref *mode*)
       ((c) ((@ (language tree-il) make-conditional)
             source test-exp then-exp else-exp))
-      (else (if (equal? else-exp '(if #f #f))
+      (else (decorate-source
-                `(if ,test-exp ,then-exp)
+             (if (equal? else-exp '(if #f #f))
-                `(if ,test-exp ,then-exp ,else-exp))))))
+                 `(if ,test-exp ,then-exp)
+                 `(if ,test-exp ,then-exp ,else-exp))
+             source)))))
 
 (define build-lexical-reference
   (lambda (type source name var)
     (case (fluid-ref *mode*)
       ((c) ((@ (language tree-il) make-lexical-ref) source name var))
-      (else var))))
+      (else (decorate-source var source)))))
 
 (define build-lexical-assignment
   (lambda (source name var exp)
     (case (fluid-ref *mode*)
       ((c) ((@ (language tree-il) make-lexical-set) source name var exp))
-      (else `(set! ,var ,exp)))))
+      (else (decorate-source `(set! ,var ,exp) source)))))
 
 ;; Before modules are booted, we can't expand into data structures from
 ;; (language tree-il) -- we need to give the evaluator the
@@ -403,11 +410,11 @@
      (lambda (mod var public?) 
        (case (fluid-ref *mode*)
          ((c) ((@ (language tree-il) make-module-ref) source mod var public?))
-         (else (list (if public? '@ '@@) mod var))))
+         (else (decorate-source (list (if public? '@ '@@) mod var) source))))
      (lambda (var)
        (case (fluid-ref *mode*)
          ((c) ((@ (language tree-il) make-toplevel-ref) source var))
-         (else var))))))
+         (else (decorate-source var source)))))))
 
 (define build-global-assignment
   (lambda (source var exp mod)
@@ -416,11 +423,11 @@
      (lambda (mod var public?) 
        (case (fluid-ref *mode*)
          ((c) ((@ (language tree-il) make-module-set) source mod var public? exp))
-         (else `(set! ,(list (if public? '@ '@@) mod var) ,exp))))
+         (else (decorate-source `(set! ,(list (if public? '@ '@@) mod var) ,exp) source))))
      (lambda (var)
        (case (fluid-ref *mode*)
          ((c) ((@ (language tree-il) make-toplevel-set) source var exp))
-         (else `(set! ,var ,exp)))))))
+         (else (decorate-source `(set! ,var ,exp) source)))))))
 
 ;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz)
 ;; from working. Hack around it.
@@ -439,7 +446,7 @@
       ((c)
        (maybe-name-value! var exp)
        ((@ (language tree-il) make-toplevel-define) source var exp))
-      (else `(define ,var ,exp)))))
+      (else (decorate-source `(define ,var ,exp) source)))))
 
 (define build-lambda
   (lambda (src ids vars docstring exp)
@@ -447,25 +454,29 @@
       ((c) ((@ (language tree-il) make-lambda) src ids vars
             (if docstring `((documentation . ,docstring)) '())
             exp))
-      (else `(lambda ,vars ,@(if docstring (list docstring) '())
+      (else (decorate-source
-                     ,exp)))))
+             `(lambda ,vars ,@(if docstring (list docstring) '())
+                      ,exp)
+             src)))))
 
 (define build-primref
   (lambda (src name)
     (if (equal? (module-name (current-module)) '(guile))
         (case (fluid-ref *mode*)
           ((c) ((@ (language tree-il) make-toplevel-ref) src name))
-          (else name))
+          (else (decorate-source name src)))
         (case (fluid-ref *mode*)
           ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f))
-          (else `(@@ (guile) ,name))))))
+          (else (decorate-source `(@@ (guile) ,name) src))))))
 
 (define (build-data src exp)
   (case (fluid-ref *mode*)
     ((c) ((@ (language tree-il) make-const) src exp))
-    (else (if (and (self-evaluating? exp) (not (vector? exp)))
+    (else (decorate-source
-              exp
+           (if (and (self-evaluating? exp) (not (vector? exp)))
-              (list 'quote exp)))))
+               exp
+               (list 'quote exp))
+           src))))
 
 (define build-sequence
   (lambda (src exps)
@@ -473,7 +484,7 @@
         (car exps)
         (case (fluid-ref *mode*)
           ((c) ((@ (language tree-il) make-sequence) src exps))
-          (else `(begin ,@exps))))))
+          (else (decorate-source `(begin ,@exps) src))))))
 
 (define build-let
   (lambda (src ids vars val-exps body-exp)
@@ -483,7 +494,9 @@
           ((c)
            (for-each maybe-name-value! ids val-exps)
            ((@ (language tree-il) make-let) src ids vars val-exps body-exp))
-          (else `(let ,(map list vars val-exps) ,body-exp))))))
+          (else (decorate-source
+                 `(let ,(map list vars val-exps) ,body-exp)
+                 src))))))
 
 (define build-named-let
   (lambda (src ids vars val-exps body-exp)
@@ -500,7 +513,9 @@
             (list f-name) (list f) (list proc)
             (build-application src (build-lexical-reference 'fun src f-name f)
                                val-exps))))
-        (else `(let ,f ,(map list vars val-exps) ,body-exp))))))
+        (else (decorate-source
+               `(let ,f ,(map list vars val-exps) ,body-exp)
+               src))))))
 
 (define build-letrec
   (lambda (src ids vars val-exps body-exp)
@@ -510,7 +525,9 @@
           ((c)
            (for-each maybe-name-value! ids val-exps)
            ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp))
-          (else `(letrec ,(map list vars val-exps) ,body-exp))))))
+          (else (decorate-source
+                 `(letrec ,(map list vars val-exps) ,body-exp)
+                 src))))))
 
 ;; FIXME: wingo: use make-lexical ?
 (define-syntax build-lexical-var