Index: /branches/gz-working/compiler/PPC/ppc2.lisp
===================================================================
--- /branches/gz-working/compiler/PPC/ppc2.lisp	(revision 8437)
+++ /branches/gz-working/compiler/PPC/ppc2.lisp	(revision 8438)
@@ -170,4 +170,5 @@
 (defvar *ppc2-record-symbols* nil)
 (defvar *ppc2-recorded-symbols* nil)
+(defvar *ppc2-emitted-source-notes* ())
 
 (defvar *ppc2-result-reg* ppc::arg_z)
@@ -471,5 +472,5 @@
                          (setq function-debugging-info (nconc (list 'function-symbol-map *ppc2-recorded-symbols*)
                                                               function-debugging-info)))
-                       (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
+                       (setq bits (logior (ash 1 $lfbits-info-bit) bits))
                        (backend-new-immediate function-debugging-info)))
                    (if (or fname lambda-form *ppc2-recorded-symbols*)
@@ -494,5 +495,7 @@
                             regsave-addr
                             (if (and fname (symbolp fname)) (symbol-name fname)))))
-                   (ppc2-digest-symbols))))
+                   (ppc2-digest-symbols)
+                   (ppc2-digest-source-notes))))
+          (ppc2-reset-source-notes)
           (backend-remove-labels))))
     afunc))
@@ -2140,5 +2143,49 @@
       (when (and vreg val-reg) (<- val-reg))
       (^))))
-                    
+
+(defun ppc2-code-coverage-entry (seg)
+  (let ((note (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note)))
+    (when note
+      (with-ppc-local-vinsn-macros (seg)
+        (! vpush-register ppc::arg_x)
+        (! misc-ref-c-node ppc::arg_x ppc::nfn (1+ (backend-immediate-index note)))
+        (! misc-set-c-node ppc::rzero ppc::arg_x 1)
+        (! vpop-register ppc::arg_x)))))
+
+(defppc2 ppc2-with-source-note with-source-note (seg vreg xfer note form &aux val)
+  (when *record-pc-mapping*
+    (append-dll-node (setq (setf (source-note-start note) (make-vinsn-label nil)) seg)))
+  (when *compile-code-coverage*
+    (with-ppc-local-vinsn-macros (seg)
+      (ppc2-store-immediate seg note ($ ppc::arg_x))
+      (! misc-set-c-node ($ ppc::rzero) ($ ppc::arg_x) 1)))
+  (setq val (ppc2-form seg vreg xfer form))
+  (when *record-pc-mapping*
+    (append-dll-node (setf (source-note-end-pc note) (make-vinsn-label nil)) seg))
+  val)
+
+(defun ppc2-digest-source-notes ()
+  (when (or *compile-code-coverage* *record-pc-mapping*)
+    (flet ((address (label)
+             (when (typep label 'vinsn-label)
+               (let ((lap-label (or (vinsn-label-info label)
+                                    (compiler-bug "Missing source note label: ~s" label))))
+                 (lap-label-address lap-label)))))
+      (labels ((rec (note)
+                 (when note
+                   (setf (source-note-start-pc note) (address (source-note-start-pc note)))
+                   (setf (source-note-end-pc note) (address (source-note-end-pc note)))
+                   (dolist (subnote (source-note-subform-notes note)) (rec subnote)))))
+        (rec (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))))))
+
+(defun ppc2-reset-source-notes ()
+  (when (or *compile-code-coverage* *record-pc-mapping*)
+    (flet ((clear (label) (if (typep label 'vinsn-label) nil label)))
+      (labels ((rec (note)
+                 (when note
+                   (setf (source-note-start-pc note) (clear (source-note-start-pc note)))
+                   (setf (source-note-end-pc note) (clear (source-note-end-pc note)))
+                   (dolist (subnote (source-note-subform-notes note)) (rec subnote)))))
+        (rec (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))))))
 
 (defun ppc2-vset (seg vreg xfer type-keyword vector index value safe)
@@ -5064,5 +5111,5 @@
     (if (%vinsn-label-p v)
       (let* ((id (vinsn-label-id v)))
-        (if (typep id 'fixnum)
+        (if (or (typep id 'fixnum) (null id))
           (when (or t (vinsn-label-refs v))
             (setf (vinsn-label-info v) (emit-lap-label v)))
@@ -5260,4 +5307,7 @@
           (ppc2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afunc-all-vars afunc) no-regs))
         (@ (backend-get-next-label)) ; generic self-reference label, should be label #1
+        (when *compile-code-coverage*
+          (ppc2-code-coverage-entry seg))
+
         (unless next-method-p
           (setq method-var nil))
@@ -9059,14 +9109,4 @@
                              (list nil (list arg))))))))
 
-(defun show-function-constants (f)
-  (cond ((typep f 'function)
-	 (do* ((i 0 j)
-	       (n (uvsize f))
-	       (j 1 (1+ j)))
-	      ((= j n))
-	   (format t "~&~d: ~s" i (uvref f j))))
-	(t (report-bad-arg f 'function))))
-
-	
 ;------
 
Index: /branches/gz-working/compiler/X86/x862.lisp
===================================================================
--- /branches/gz-working/compiler/X86/x862.lisp	(revision 8437)
+++ /branches/gz-working/compiler/X86/x862.lisp	(revision 8438)
@@ -578,5 +578,5 @@
                          (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
                                                               function-debugging-info)))
-                       (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
+                       (setq bits (logior (ash 1 $lfbits-info-bit) bits))
                        (setq debug-info function-debugging-info)))
                    (unless (or fname lambda-form *x862-recorded-symbols*)
@@ -2280,5 +2280,24 @@
       (^))))
           
-          
+(defx862 x862-code-coverage code-coverage (seg vreg xfer ccrec form)
+  (with-x86-local-vinsn-macros (seg)
+    (x862-store-immediate seg ccrec x8664::arg_x)
+    (! load-t x8664::arg_y)
+    (! misc-set-c-node x8664::arg_y x8664::arg_x 1))
+  (x862-form seg vreg xfer form))
+
+(defun x862-code-coverage-entry (seg)
+ (let ((ccrec (getf (afunc-lfun-info *x862-cur-afunc*) 'function-code-coverage)))
+   (when ccrec
+     (with-x86-local-vinsn-macros (seg)
+       (let* ((ccreg ($ x8664::arg_x))
+	      (valreg ($ x8664::arg_z)))
+	 (! vpush-register ccreg)
+	 (! vpush-register valreg)
+	 (! ref-constant x8664::arg_x  (x86-immediate-label ccrec))
+	 (! load-t valreg)
+	 (! misc-set-c-node valreg ccreg 1)
+	 (! vpop-register valreg)
+	 (! vpop-register ccreg))))))
 
 (defun x862-vset (seg vreg xfer type-keyword vector index value safe)
@@ -5258,5 +5277,5 @@
       (if (%vinsn-label-p v)
         (let* ((id (vinsn-label-id v)))
-          (if (typep id 'fixnum)
+          (if (or (typep id 'fixnum) (null id))
             (when (or t (vinsn-label-refs v))
               (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v)))
@@ -5529,4 +5548,6 @@
         (! establish-fn)
         (@ (backend-get-next-label)) ; self-call label
+	(x862-code-coverage-entry seg)
+
         (unless next-method-p
           (setq method-var nil))
@@ -9148,11 +9169,5 @@
                          *target-ftd*)))
     (multiple-value-bind (xlfun warnings)
-        (compile-named-function def nil
-                                nil
-                                nil
-                                nil
-                                nil
-                                nil
-                                target)
+        (compile-named-function def :target target)
       (signal-or-defer-warnings warnings nil)
       (when disassemble
Index: /branches/gz-working/compiler/lambda-list.lisp
===================================================================
--- /branches/gz-working/compiler/lambda-list.lisp	(revision 8437)
+++ /branches/gz-working/compiler/lambda-list.lisp	(revision 8438)
@@ -25,9 +25,12 @@
   (getf (%lfun-info fn) 'function-symbol-map))
 
+(defun function-source-text (fn)
+  (get (%lfun-info fn) 'text))
+
 (defun %lfun-info-index (fn)
   (and (compiled-function-p fn)
        (let ((bits (lfun-bits fn)))
          (declare (fixnum bits))
-         (and (logbitp $lfbits-symmap-bit bits)
+         (and (logbitp $lfbits-info-bit bits)
                (%i- (uvsize (function-to-function-vector fn))
                               (if (logbitp $lfbits-noname-bit bits) 2 3))))))
Index: /branches/gz-working/compiler/nx-basic.lisp
===================================================================
--- /branches/gz-working/compiler/nx-basic.lisp	(revision 8437)
+++ /branches/gz-working/compiler/nx-basic.lisp	(revision 8438)
@@ -489,3 +489,3 @@
       (cdr (assq name (defenv.structrefs defenv))))))
 
-; end
+;end
Index: /branches/gz-working/compiler/nx.lisp
===================================================================
--- /branches/gz-working/compiler/nx.lisp	(revision 8437)
+++ /branches/gz-working/compiler/nx.lisp	(revision 8438)
@@ -88,5 +88,8 @@
                        (if (functionp def)
                          def
-                         (compile-named-function def spec nil *save-definitions* *save-local-symbols*))
+                         (compile-named-function def
+                                                 :name spec
+                                                 :keep-lambda *save-definitions*
+                                                 :keep-symbols *save-local-symbols*))
     (let ((harsh nil) (some nil) (init t))
       (dolist (w warnings)
@@ -121,11 +124,5 @@
          (*target-backend* (or backend *target-backend*)))
     (multiple-value-bind (xlfun warnings)
-        (compile-named-function def nil
-                                nil
-                                nil
-                                nil
-                                nil
-                                nil
-                                target)
+        (compile-named-function def :target target)
       (signal-or-defer-warnings warnings nil)
       (ppc-xdisassemble xlfun :target target)
@@ -134,8 +131,9 @@
 (defun compile-user-function (def name &optional env)
   (multiple-value-bind (lfun warnings)
-                       (compile-named-function def name
-                                               env
-                                               *save-definitions*
-                                               *save-local-symbols*)
+                       (compile-named-function def
+                                               :name name
+                                               :env env
+                                               :keep-lambda *save-definitions*
+                                               :keep-symbols *save-local-symbols*)
     (signal-or-defer-warnings warnings env)
     lfun))
@@ -153,7 +151,17 @@
 
 (defparameter *load-time-eval-token* nil)
-
-
-
+(defparameter *nx-source-note-map* nil)
+
+(defmacro nx-source-note (form)
+  `(gethash ,form *nx-source-note-map*))
+
+(defun nx-find-or-make-source-note (form parent)
+  ;; Here's a fun code coverage issue:  What if the same source form gets used multiple
+  ;; times. e.g. (macrolet ((dup (x) `(progn (foo ,x) (bar ,x)))) (dup (something))).
+  ;; We could arrange to have separate records for each instance, but as of right now no
+  ;; existing or contemplated UI has a means of showing the distinction, so don't bother.
+  (or (nx-source-note form)
+      (and (consp form)
+           (setf (nx-source-note form) (make-source-note :form form :source parent)))))
 
 (eval-when (:compile-toplevel)
@@ -162,11 +170,27 @@
 (defparameter *nx-discard-xref-info-hook* nil)
 
-(defun compile-named-function
-    (def &optional name env keep-lambda keep-symbols policy *load-time-eval-token* target)
+(defun compile-named-function (def &rest args)
+  ;; For bootstrapping.  TODO: Switch to keyword version once fully bootstrapped
+  (if (and (evenp (length args))
+           (loop for aa on args by #'cddr always (keywordp (car aa))))
+    (apply #'compile-named-function-1 def args)
+    (destructuring-bind (&optional name env keep-lambda keep-symbols policy load-time-eval-token target) args
+      (compile-named-function-1 def
+                                :name name
+                                :env env
+                                :keep-lambda keep-lambda
+                                :keep-symbols keep-symbols
+                                :policy policy
+                                :load-time-eval-token load-time-eval-token
+                                :target target))))
+
+(defun compile-named-function-1 (def &key name env source keep-lambda keep-symbols policy load-time-eval-token target source-locations)
   (when (and name *nx-discard-xref-info-hook*)
     (funcall *nx-discard-xref-info-hook* name))
   (setq 
    def
-   (let ((env (new-lexical-environment env)))
+   (let ((*load-time-eval-token* load-time-eval-token)
+         (*nx-source-note-map* source-locations)
+         (env (new-lexical-environment env)))
      (setf (lexenv.variables env) 'barrier)
        (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
@@ -178,5 +202,6 @@
                       env 
                       (or policy *default-compiler-policy*)
-                      *load-time-eval-token*)))
+                      *load-time-eval-token*
+                      source)))
          (if (afunc-lfun afunc)
            afunc
Index: /branches/gz-working/compiler/nx0.lisp
===================================================================
--- /branches/gz-working/compiler/nx0.lisp	(revision 8437)
+++ /branches/gz-working/compiler/nx0.lisp	(revision 8438)
@@ -55,5 +55,5 @@
 (defvar *nx1-fcells* nil)
 
-(defvar *nx1-operators* (make-hash-table :size 160 :test #'eq))
+(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
 
                                          
@@ -78,4 +78,5 @@
 (defvar *nx-operators* ())
 (defvar *nx-warnings* nil)
+(defvar *nx-ccrec* nil)
 
 (defvar *nx1-compiler-special-forms* nil "Real special forms")
@@ -91,5 +92,6 @@
 (defvar *cross-compiling* nil "bootstrapping")
 
-
+(defvar *compile-code-coverage* nil "True to instrument for code coverage")
+(defvar *record-pc-mapping* nil "True to record pc -> source mapping")
 
 (defparameter *nx-operator-result-types*
@@ -208,6 +210,5 @@
     (let ((body (parse-macro-1 block-name arglist body env)))
       `(eval-when (:compile-toplevel :load-toplevel :execute)
-        (eval-when (:load-toplevel :execute)
-          (record-source-file ',name 'compiler-macro))
+        (record-source-file ',name 'compiler-macro)
         (setf (compiler-macro-function ',name)
          (nfunction (compiler-macro-function ,name)  ,body))
@@ -1251,5 +1252,6 @@
                                  parent-env
                                  (policy *default-compiler-policy*)
-                                 load-time-eval-token)
+                                 load-time-eval-token
+                                 source)
   (if q
      (setf (afunc-parent p) q))
@@ -1284,5 +1286,5 @@
                          (parse-body (%cddr lambda-form) *nx-lexical-environment* t)
       (setf (afunc-lambdaform p) lambda-form)
-      (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls))
+      (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls source))
       (nx1-transitively-punt-bindings *nx-punted-vars*)
       (setf (afunc-blocks p) *nx-blocks*)
@@ -1308,10 +1310,21 @@
 
 
-
-
-
-(defun nx1-lambda (ll body decls &aux (l ll) methvar)
-  (let ((old-env *nx-lexical-environment*)
-        (*nx-bound-vars* *nx-bound-vars*))
+(defun make-afunc-source-note (afunc source-form)
+  ;; Makes a source note and stores it in the lfun-info.
+  (let* ((source-note (nx-find-or-make-source-note source-form nil))
+         (lambda (afunc-lambdaform afunc))
+         (lambda-note (nx-find-or-make-source-note lambda source-note)))
+    (setf (afunc-lfun-info afunc)
+          (list* 'function-source-note lambda-note (afunc-lfun-info afunc)))
+    lambda-note))
+
+(defun nx1-lambda (ll body decls &optional source-form &aux (l ll) methvar)
+  (let* ((old-env *nx-lexical-environment*)
+         (*nx-bound-vars* *nx-bound-vars*)
+         ;; Make a toplevel source note even if not recording pc mapping or code coverage,
+         ;; just to store it for lfun source location info.
+         (source-note (when *nx-source-note-map*
+                        (make-afunc-source-note *nx-current-function* source-form)))
+         (*nx-ccrec* (and (or *compile-code-coverage* *record-pc-mapping*) source-note)))
     (with-nx-declarations (pending)
       (let* ((*nx-parsing-lambda-decls* t))
@@ -1323,5 +1336,5 @@
               (nx-error "invalid lambda-list  - ~s" l)))
           (return-from nx1-lambda
-                       (list
+                       (make-acode
                         (%nx1-operator lambda-list)
                         (list (cons '&lap bits))
@@ -1371,5 +1384,5 @@
          body
          *nx-new-p2decls*)))))
-  
+
 (defun nx-parse-simple-lambda-list (pending ll &aux
 					      req
@@ -1565,7 +1578,16 @@
 
 (defun nx1-typed-form (original env)
-  (nx1-transformed-form (nx-transform original env) env))
-
-(defun nx1-transformed-form (form &optional (env *nx-lexical-environment*))
+  (nx1-transformed-form (nx-transform original env) env original))
+
+(defun nx1-transformed-form (form env &optional original)
+  (if *nx-ccrec*
+    (let* ((original (or original form))
+           (*nx-ccrec* (nx-find-or-make-source-note original *nx-ccrec*)))
+      (make-acode (%nx1-operator with-source-note)
+		  *nx-ccrec*
+                  (nx1-transformed-form-aux form env)))
+    (nx1-transformed-form-aux form env)))
+
+(defun nx1-transformed-form-aux (form env)
   (if (consp form)
     (nx1-combination form env)
@@ -1579,5 +1601,4 @@
         (nx1-symbol form env)
         (nx1-immediate (nx-unquote constant-value))))))
-
 
 
Index: /branches/gz-working/compiler/nx1.lisp
===================================================================
--- /branches/gz-working/compiler/nx1.lisp	(revision 8437)
+++ /branches/gz-working/compiler/nx1.lisp	(revision 8438)
@@ -29,13 +29,14 @@
       (setq typespec '*)
       (setq typespec (nx-target-type (type-specifier ctype)))))
-  (let* ((*nx-form-type* typespec)
-         (transformed (nx-transform form env)))
-    (if (and (consp transformed)
-             (eq (car transformed) 'the))
-        (setq transformed form))
+  (let* ((*nx-form-type* typespec))
     (make-acode
      (%nx1-operator typed-form)
      typespec
-     (nx1-transformed-form transformed env))))
+     (nx1-transformed-form (let ((transformed (nx-transform form env)))
+                             (if (and (consp transformed)
+                                      (eq (car transformed) 'the))
+                               form
+                               transformed))
+                           env form))))
 
 (defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
@@ -86,5 +87,6 @@
           (cons
            'macro
-           (multiple-value-bind (function warnings) (compile-named-function (parse-macro name arglist mbody old-env) name  old-env)
+           (multiple-value-bind (function warnings) (compile-named-function (parse-macro name arglist mbody old-env)
+                                                                            :name name :env old-env)
              (setq *nx-warnings* (append *nx-warnings* warnings))
              function)))
@@ -1059,5 +1061,7 @@
     (multiple-value-bind (function warnings)
                          (compile-named-function 
-                          `(lambda () ,form) nil nil nil nil nil *nx-load-time-eval-token* (backend-name *target-backend*))
+                          `(lambda () ,form)
+                          :load-time-eval-token  *nx-load-time-eval-token*
+                          :target (backend-name *target-backend*))
       (setq *nx-warnings* (append *nx-warnings* warnings))
       (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function))))
Index: /branches/gz-working/compiler/nxenv.lisp
===================================================================
--- /branches/gz-working/compiler/nxenv.lisp	(revision 8437)
+++ /branches/gz-working/compiler/nxenv.lisp	(revision 8438)
@@ -28,4 +28,6 @@
 #+ppc-target (require "PPCENV")
 #+x8664-target (require "X8664ENV")
+
+#-BOOTSTRAPPED (unless (boundp '$lfbits-info-bit) (set '$lfbits-info-bit 2))
 
 (defconstant $afunc-size 
@@ -410,5 +412,6 @@
      (general-aref2 .  #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
      (%single-float .  #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
-     (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)))))
+     (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
+     (with-source-note . #.(logior operator-assignment-free-mask)))))
 
 (defmacro %nx1-operator (sym)
Index: /branches/gz-working/level-1/l1-reader.lisp
===================================================================
--- /branches/gz-working/level-1/l1-reader.lisp	(revision 8437)
+++ /branches/gz-working/level-1/l1-reader.lisp	(revision 8438)
@@ -2461,30 +2461,44 @@
 ;;; rewriting those parts of the CLOS and I/O code that make
 ;;; using things like READ-CHAR impractical ...
+;;; mb: the reason multiple-value-list is used here is that we need to distinguish between the
+;;; recursive parse call returning (values nil) and (values).
 (defun %parse-expression (stream firstchar dot-ok)
   (let* ((readtable *readtable*)
-         (attrtab (rdtab.ttab readtable)))
-    (let* ((attr (%character-attribute firstchar attrtab)))
-      (declare (fixnum attr))
-      (if (= attr $cht_ill)
-          (signal-reader-error stream "Illegal character ~S." firstchar))
-      (let* ((vals (multiple-value-list 
-                    (if (not (logbitp $cht_macbit attr))
-                      (%parse-token stream firstchar dot-ok)
-                      (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
-                        (cond ((null def))
-                              ((atom def)
-                               (funcall def stream firstchar))
-                              #+no ; include if %initial-readtable% broken (see above)
-                              ((and (consp (car def))
-                                    (eq (caar def) 'function))
-                               (funcall (cadar def) stream firstchar))
-                              ((functionp (car def))
-                               (funcall (car def) stream firstchar))
-                              (t (error "Bogus default dispatch fn: ~S" (car def)) nil)))))))
-        (declare (dynamic-extent vals)
-                 (list vals))
-        (if (null vals)
-            (values nil nil)
-            (values (car vals) t))))))
+         (attrtab (rdtab.ttab readtable))
+         (attr (%character-attribute firstchar attrtab))
+         (start-pos (file-position stream)))
+    (declare (fixnum attr))
+    (if (= attr $cht_ill)
+        (signal-reader-error stream "Illegal character ~S." firstchar))
+    (let* ((vals (multiple-value-list 
+                  (if (not (logbitp $cht_macbit attr))
+                    (%parse-token stream firstchar dot-ok)
+                    (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
+                      (cond ((null def))
+                            ((atom def)
+                             (funcall def stream firstchar))
+                            #+no ; include if %initial-readtable% broken (see above)
+                            ((and (consp (car def))
+                                  (eq (caar def) 'function))
+                             (funcall (cadar def) stream firstchar))
+                            ((functionp (car def))
+                             (funcall (car def) stream firstchar))
+                            (t (error "Bogus default dispatch fn: ~S" (car def)) nil))))))
+           (end-pos (and start-pos (file-position stream))))
+      (declare (dynamic-extent vals)
+               (list vals))
+      (if (null vals)
+        (values nil nil)
+        (destructuring-bind (form &optional nested-source-notes)
+                            vals
+          (values form
+                  t
+                  (and (consp form)
+                       start-pos
+                       (make-source-note :form form
+                                         :stream stream
+                                         :start-pos (1- start-pos)
+                                         :end-pos end-pos
+                                         :subform-notes nested-source-notes))))))))
 
 
@@ -2505,7 +2519,8 @@
         (if (eq firstch termch)
             (return (values nil nil))
-            (multiple-value-bind (val val-p) (%parse-expression stream firstch dot-ok)
+            (multiple-value-bind (val val-p source-info)
+                                 (%parse-expression stream firstch dot-ok)
               (if val-p
-                  (return (values val t))))))))
+                  (return (values val t source-info))))))))
 
 
@@ -2513,10 +2528,13 @@
   (let* ((dot-ok (cons nil nil))
          (head (cons nil nil))
-         (tail head))
+         (tail head)
+         (source-note-list nil))
     (declare (dynamic-extent dot-ok head)
              (list head tail))
     (if nodots (setq dot-ok nil))
-    (multiple-value-bind (firstform firstform-p)
+    (multiple-value-bind (firstform firstform-p firstform-source-note)
         (%read-list-expression stream dot-ok termch)
+      (when firstform-source-note
+        (push firstform-source-note source-note-list))
       (when firstform-p
         (if (and dot-ok (eq firstform dot-ok))       ; just read a dot
@@ -2524,17 +2542,22 @@
         (rplacd tail (setq tail (cons firstform nil)))
         (loop
-          (multiple-value-bind (nextform nextform-p)
+          (multiple-value-bind (nextform nextform-p nextform-source-note)
               (%read-list-expression stream dot-ok termch)
+            (when nextform-source-note
+              (push nextform-source-note source-note-list))
             (if (not nextform-p) (return))
             (if (and dot-ok (eq nextform dot-ok))    ; just read a dot
-                (if (multiple-value-bind (lastform lastform-p)
+                (if (multiple-value-bind (lastform lastform-p lastform-source-note)
                         (%read-list-expression stream nil termch)
+                      (when lastform-source-note
+                        (push lastform-source-note source-note-list))
                       (and lastform-p
-                           (progn (rplacd tail lastform) 
+                           (progn (rplacd tail lastform)
                                   (not (nth-value 1 (%read-list-expression stream nil termch))))))
                     (return)
                     (signal-reader-error stream "Dot context error."))
-                (rplacd tail (setq tail (cons nextform nil))))))))
-    (cdr head)))
+                (progn
+                  (rplacd tail (setq tail (cons nextform nil)))))))))
+    (values (cdr head) source-note-list)))
 
 #|
@@ -2840,4 +2863,8 @@
 (defun read (&optional stream (eof-error-p t) eof-value recursive-p)
   (declare (resident))
+  ;; just return the first value of read-internal
+  (values (read-internal stream eof-error-p eof-value recursive-p)))
+
+(defun read-internal (stream eof-error-p eof-value recursive-p)
   (setq stream (input-stream-arg stream))
   (if recursive-p
@@ -2858,5 +2885,5 @@
 (defun read-delimited-list (char &optional stream recursive-p)
   "Read Lisp values from INPUT-STREAM until the next character after a
-   value's representation is ENDCHAR, and return the objects as a list."
+   value's representation is CHAR, and return the objects as a list."
   (setq char (require-type char 'character))
   (setq stream (input-stream-arg stream))
@@ -2912,10 +2939,10 @@
               (error 'end-of-file :stream stream)
               (return eof-val))
-            (multiple-value-bind (form form-p) (%parse-expression stream ch nil)
-              (if form-p
-                 (if *read-suppress*
-                     (return nil)
-                     (return form)))))))))
-
+            (multiple-value-bind (form form-p source-note)
+                                 (%parse-expression stream ch nil)
+              (when form-p
+                (return
+                 (values (if *read-suppress* nil form)
+                         source-note)))))))))
 
 
@@ -2950,5 +2977,101 @@
 
 
-
-
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defstruct (source-note (:constructor %make-source-note))
+  ;; Code coverage state.  This MUST be the first slot - see nx**2-code-coverage.
+  code-coverage
+  ;; The actual form
+  form
+  ;; The source location: file name, and start/end offsets within the file
+  file-name
+  start-pos
+  end-pos
+  ;; For the outermost source form, a string (the text of the form).
+  ;; For an inner source form, the source-note of the outer source form.
+  ;; For a generated form (no file info), source-note of original form.
+  source
+  ;; PC information generated by compiler.  For source notes not stored in
+  ;; an lfun, it could contain garbage if compilation of containing form
+  ;; was started and interrupted.
+  start-pc
+  end-pc
+  ;; Notes for code-generating subforms of this form
+  subform-notes)
+
+(defun source-note-length (note)
+  (- (source-note-end-pos note) (source-note-start-pos note)))
+
+(defun source-note-text (note)
+  (multiple-value-bind (string offset) (source-note-string-and-offset note)
+    (subseq string offset (+ offset (source-note-length note)))))
+
+(defun source-note-string-and-offset (note)
+  "Returns a string and offset where the text of note's form starts"
+  (let ((source (source-note-source note)))
+    (cond ((stringp source)
+           (assert (<= (source-note-length note) (length source)))
+           (values source 0))
+          (t
+           (let ((start (source-note-start-pos note))
+                 (parent-start (source-note-start-pos source)))
+           (assert (<= parent-start start
+                       (source-note-end-pos note) (source-note-end-pos source)))
+           (multiple-value-bind (parent-string parent-offset)
+                                (source-note-string-and-offset source)
+             (values parent-string (+ parent-offset (- start parent-start)))))))))
+
+(defvar *recording-source-streams* ())
+
+(defun read-recording-source (stream &key eofval file-name start-offset map)
+  "Read a top-level form recording source location notes in MAP"
+  (if (null map)
+    (values (read-internal stream nil eofval nil))
+    (let* ((recording (list stream map file-name start-offset))
+           (*recording-source-streams* (cons recording *recording-source-streams*)))
+      (declare (dynamic-extent recording *recording-source-streams*))
+      (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
+        (when (and source-note (not (eq form eofval)))
+          (assert (null (source-note-source source-note)))
+          (let ((text (make-string (source-note-length source-note)))
+                (pos (file-position stream)))
+            (file-position stream (- (source-note-start-pos source-note) start-offset))
+            (read-sequence text stream)
+            (file-position stream pos)
+            (setf (source-note-source source-note) text)))
+        form))))
+
+(defun make-source-note (&key form stream start-pos end-pos subform-notes source)
+  (assert (or (null source) (null (or stream start-pos end-pos subform-notes))))
+  (if stream
+    ;; source note for form read from a stream
+    (let ((recording (assoc stream *recording-source-streams*)))
+      (assert (null source))
+      (when (and recording (not *read-suppress*))
+        (destructuring-bind (map file-name stream-offset) (cdr recording)
+          (let ((note (%make-source-note :form form
+                                         :file-name file-name
+                                         :start-pos (+ stream-offset start-pos)
+                                         :end-pos (+ stream-offset end-pos))))
+            (setf (gethash form map) note)
+            (labels ((rec (subnote)
+                       (cond
+                        ((consp subnote)
+                         (if (null (car subnote))
+                           (rec (cdr subnote))
+                           (progn (rec (car subnote)) (rec (cdr subnote)))))
+                        ((source-note-p subnote)
+                         (unless (source-note-source subnote)
+                           (setf (source-note-source subnote) note)))
+                        #| ((null note) '()) 
+                        (t (error "Don't know how to deal with a source note like ~S."
+                                  nested-source-notes)) |# )))
+              (rec subform-notes))
+            note)))) 
+    ;; Else note for a form generated by macroexpansion
+    (let* ((source (and source (require-type source 'source-note)))
+           (note (%make-source-note :form form :source source)))
+      (when source (push note (source-note-subform-notes source)))
+      note)))
+
+; end
Index: /branches/gz-working/lib/db-io.lisp
===================================================================
--- /branches/gz-working/lib/db-io.lisp	(revision 8437)
+++ /branches/gz-working/lib/db-io.lisp	(revision 8438)
@@ -843,5 +843,5 @@
    (declare (ignore char arg))
    (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
-     (multiple-value-bind (sym query)
+     (multiple-value-bind (sym source query)
          (%read-symbol-preserving-case
           stream
@@ -849,10 +849,12 @@
        (unless *read-suppress*
          (let* ((fv (%load-var sym query)))
-           (if query
-             fv
-             (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
-                                   (fv.type fv)
-                                   0
-                                   nil))))))))
+           (values
+            (if query
+              fv
+              (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
+                                    (fv.type fv)
+                                    0
+                                    nil))
+            source)))))))
 
 
@@ -987,5 +989,6 @@
          (query nil)
 	 (error nil)
-	 (sym nil))
+	 (sym nil)
+         (source nil))
     (let* ((*package* package))
       (unwind-protect
@@ -995,11 +998,11 @@
                (setq query t)
                (read-char stream))
-	     (multiple-value-setq (sym error)
-	       (handler-case (read stream nil nil)
-		 (error (condition) (values nil condition)))))
+	     (multiple-value-setq (sym source error)
+	       (handler-case (read-internal stream nil t nil)
+		 (error (condition) (values nil nil condition)))))
 	(setf (readtable-case *readtable*) case)))
     (when error
       (error error))
-    (values sym query)))
+    (values sym source query)))
 
 (set-dispatch-macro-character 
@@ -1008,5 +1011,5 @@
    (declare (ignore char))
    (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
-     (multiple-value-bind (sym query)
+     (multiple-value-bind (sym source query)
          (%read-symbol-preserving-case
 	    stream
@@ -1016,5 +1019,5 @@
            (symbol
             (if query
-              (load-os-constant sym query)
+              (values (load-os-constant sym query) source)
               (progn
                 (when (eq (symbol-package sym) package)
@@ -1027,9 +1030,9 @@
                        (load-os-constant sym)))
                     (1 (makunbound sym) (load-os-constant sym))))
-                sym)))
+                (values sym source))))
            (string
             (let* ((val 0)
                    (len (length sym)))
-              (dotimes (i 4 val)
+              (dotimes (i 4 (values val source))
                 (let* ((ch (if (< i len) (char sym i) #\space)))
                   (setq val (logior (ash val 8) (char-code ch)))))))))))))
@@ -1039,5 +1042,5 @@
     (declare (ignore char))
     (unless arg (setq arg 0))
-    (multiple-value-bind (sym query)
+    (multiple-value-bind (sym source query)
         (%read-symbol-preserving-case
 		 stream
@@ -1046,11 +1049,12 @@
         (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol))
         (if query
-          (load-external-function sym t)
+          (values (load-external-function sym t) source)
           (let* ((def (if (eql arg 0)
                         (gethash sym (ftd-external-function-definitions
                                       *target-ftd*)))))
-            (if (and def (eq (macro-function sym) #'%external-call-expander))
-              sym
-              (load-external-function sym nil))))))))
+            (values (if (and def (eq (macro-function sym) #'%external-call-expander))
+                      sym
+                      (load-external-function sym nil))
+                    source)))))))
 
 (set-dispatch-macro-character
Index: /branches/gz-working/lib/defstruct-lds.lisp
===================================================================
--- /branches/gz-working/lib/defstruct-lds.lisp	(revision 8437)
+++ /branches/gz-working/lib/defstruct-lds.lisp	(revision 8438)
@@ -257,4 +257,5 @@
          ,(if (and predicate (null (sd-type sd))) `',predicate)
          ,.(if documentation (list documentation)))
+        (record-source-file ',(sd-name sd) 'structure)
         ,(%defstruct-compile sd refnames)
        ;; Wait until slot accessors are defined, to avoid
Index: /branches/gz-working/lib/defstruct.lisp
===================================================================
--- /branches/gz-working/lib/defstruct.lisp	(revision 8437)
+++ /branches/gz-working/lib/defstruct.lisp	(revision 8438)
@@ -97,5 +97,4 @@
     (set-documentation name 'type doc))  
   (puthash name %defstructs% sd)
-  (record-source-file name 'structure)
   (when (and predicate (null (sd-type sd)))
     (puthash predicate %structure-refs% name))  
Index: /branches/gz-working/lib/encapsulate.lisp
===================================================================
--- /branches/gz-working/lib/encapsulate.lisp	(revision 8437)
+++ /branches/gz-working/lib/encapsulate.lisp	(revision 8438)
@@ -584,4 +584,13 @@
     res))
 
+(defmacro with-traces (syms &body body)
+  `(unwind-protect
+        (progn
+          (let ((*trace-output* (make-broadcast-stream)))
+            ;; if you're tracing ccl internals you'll get trace output as it encapsulates the
+            ;; functions so hide all the trace output while eval'ing teh trace form itself.
+            (trace ,@syms))
+          ,@body)
+     (untrace ,@syms)))
 
 ;; this week def is the name of an uninterned gensym whose fn-cell is original def
@@ -683,5 +692,6 @@
 
 (defun compile-named-function-warn (fn name)
-  (multiple-value-bind (result warnings)(compile-named-function fn name)    
+  (multiple-value-bind (result warnings)
+                       (compile-named-function fn :name name)
     (when warnings 
       (let ((first t))
Index: /branches/gz-working/lib/misc.lisp
===================================================================
--- /branches/gz-working/lib/misc.lisp	(revision 8437)
+++ /branches/gz-working/lib/misc.lisp	(revision 8438)
@@ -704,5 +704,5 @@
         (setq fun (closure-function fun)))
     (when (lambda-expression-p fun)
-      (setq fun (compile-named-function fun nil)))
+      (setq fun (compile-named-function fun)))
     fun))
 
Index: /branches/gz-working/lib/nfcomp.lisp
===================================================================
--- /branches/gz-working/lib/nfcomp.lisp	(revision 8437)
+++ /branches/gz-working/lib/nfcomp.lisp	(revision 8438)
@@ -30,4 +30,10 @@
 (require 'defstruct-macros)
 
+#-BOOTSTRAPPED (unless (fboundp 'read-recording-source)
+                 (defun read-internal (stream &optional eof-error-p eofval recursive-p)
+                   (read stream eof-error-p eofval recursive-p))
+                 (defun read-recording-source (stream &key eofval file-name start-offset map)
+                   (read stream nil eofval nil)))
+
 
 (defmacro short-fixnum-p (fixnum)
@@ -47,4 +53,5 @@
 ;they should be in the product just in case we need them for patches....
 (defvar *fasl-save-local-symbols* t)
+(defvar *fasl-save-source-locations* nil)
 (defvar *fasl-deferred-warnings* nil)
 (defvar *fasl-non-style-warnings-signalled-p* nil)
@@ -60,4 +67,8 @@
   "The TRUENAME of the file currently being compiled, or NIL if not
   compiling.") ; truename ...
+(defvar *compile-file-original-truename* nil
+  "The name to use for recording source locations")
+(defvar *compile-file-original-buffer-offset* nil
+  "Start offset to use for recording source locations")
 (defvar *fasl-target* (backend-name *host-backend*))
 (defvar *fasl-backend* *host-backend*)
@@ -108,4 +119,5 @@
                          (target *fasl-target* target-p)
                          (save-local-symbols *fasl-save-local-symbols*)
+                         (save-source-locations *fasl-save-source-locations*)
                          (save-doc-strings *fasl-save-doc-strings*)
                          (save-definitions *fasl-save-definitions*)
@@ -121,5 +133,6 @@
 	(restart-case
 	 (return (%compile-file src output-file verbose print load features
-				save-local-symbols save-doc-strings save-definitions force backend external-format))
+				save-local-symbols save-source-locations save-doc-strings save-definitions
+                                force backend external-format))
 	 (retry-compile-file ()
 			     :report (lambda (stream) (format stream "Retry compiling ~s" src))
@@ -131,6 +144,6 @@
 
 (defun %compile-file (src output-file verbose print load features
-                          save-local-symbols save-doc-strings save-definitions force target-backend external-format
-			  &aux orig-src)
+                          save-local-symbols save-source-locations save-doc-strings save-definitions
+                          force target-backend external-format &aux orig-src)
 
   (setq orig-src (merge-pathnames src))
@@ -164,4 +177,5 @@
              (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
              (*fasl-save-local-symbols* save-local-symbols)
+             (*fasl-save-source-locations* save-source-locations)
              (*fasl-save-doc-strings* save-doc-strings)
              (*fasl-save-definitions* save-definitions)
@@ -246,6 +260,7 @@
                               (signal c))))
       (funcall (compile-named-function
-                `(lambda () ,form) nil env nil nil
-                *compile-time-evaluation-policy*)))))
+                `(lambda () ,form)
+                :env env
+                :policy *compile-time-evaluation-policy*)))))
 
 
@@ -315,4 +330,5 @@
 (defvar *fcomp-output-list*)
 (defvar *fcomp-toplevel-forms*)
+(defvar *fcomp-source-note-map*)
 (defvar *fcomp-warnings-header*)
 (defvar *fcomp-stream-position* nil)
@@ -390,4 +406,5 @@
            (*fasl-eof-forms* nil)
            (*loading-file-source-file* (namestring orig-file)) ; why orig-file???
+           (*fcomp-source-note-map* (and *fasl-save-source-locations* (make-hash-table)))
            (eofval (cons nil nil))
            (read-package nil)
@@ -415,11 +432,15 @@
                                 (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
                                 (signal c))))
-                  (setq form (read stream nil eofval)))))
+                  (setq form (read-recording-source stream
+                                                    :eofval eofval
+                                                    :file-name (or *compile-file-original-truename* (truename stream))
+                                                    :start-offset (or *compile-file-original-buffer-offset* 0)
+                                                    :map *fcomp-source-note-map*)))))
             (when (eq eofval form) (return))
-            (fcomp-form form env processing-mode)
+            (fcomp-form form env processing-mode form)
             (setq *fcomp-previous-position* *fcomp-stream-position*))))
       (while (setq form *fasl-eof-forms*)
         (setq *fasl-eof-forms* nil)
-        (fcomp-form-list form env processing-mode))
+        (fcomp-form-list form env processing-mode nil))
       (when old-file
         (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*)))
@@ -428,5 +449,5 @@
 
 
-(defun fcomp-form (form env processing-mode
+(defun fcomp-form (form env processing-mode &optional source
                         &aux print-stuff 
                         (load-time (and processing-mode (neq processing-mode :compile-time)))
@@ -467,14 +488,24 @@
                              "  (Compiletime)"
                              "")))))))
-    (fcomp-form-1 form env processing-mode)))
-           
-(defun fcomp-form-1 (form env processing-mode &aux sym body)
+    (fcomp-form-1 form env processing-mode source)))
+
+(defun fcomp-form-1 (form env processing-mode &optional source &aux sym body)
   (if (consp form) (setq sym (%car form) body (%cdr form)))
   (case sym
-    (progn (fcomp-form-list body env processing-mode))
-    (eval-when (fcomp-eval-when body env processing-mode))
-    (compiler-let (fcomp-compiler-let body env processing-mode))
-    (locally (fcomp-locally body env processing-mode))
-    (macrolet (fcomp-macrolet body env processing-mode))
+    (progn
+      (fcomp-form-list body env processing-mode source))
+    (eval-when
+      (fcomp-eval-when body env processing-mode source))
+    (compiler-let
+      (fcomp-compiler-let body env processing-mode source))
+    (locally
+      (fcomp-locally body env processing-mode source))
+    (macrolet
+      (fcomp-macrolet body env processing-mode source))
+   #|;; special case for passing around source-location info
+    (%source-note
+       (fcomp-form (list 'quote (source-note-to-list *definition-source-note*))
+                 end processing-mode))
+    |#
     ((%include include) (fcomp-include form env processing-mode))
     (t
@@ -489,11 +520,13 @@
              (not (eq sym '%defvar-init)) ;  a macro that we want to special-case
              (multiple-value-bind (new win) (macroexpand-1 form env)
-               (if win (setq form new))
+               (when win
+                 (setq form new))
                win))
-        (fcomp-form form env processing-mode))
+        (fcomp-form form env processing-mode source))
        ((and (not *fcomp-inside-eval-always*)
              (memq sym *fcomp-eval-always-functions*))
-        (let* ((*fcomp-inside-eval-always* t))
-          (fcomp-form-1 `(eval-when (:execute :compile-toplevel :load-toplevel) ,form) env processing-mode)))
+        (let* ((*fcomp-inside-eval-always* t)
+               (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form)))
+          (fcomp-form-1 new env processing-mode source)))
        (t
         (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too))
@@ -501,20 +534,20 @@
         (when (and processing-mode (neq processing-mode :compile-time))
           (case sym
-            ((%defconstant) (fcomp-load-%defconstant form env))
-            ((%defparameter) (fcomp-load-%defparameter form env))
-            ((%defvar %defvar-init) (fcomp-load-defvar form env))
-            ((%defun) (fcomp-load-%defun form env))
+            ((%defconstant) (fcomp-load-%defconstant form env source))
+            ((%defparameter) (fcomp-load-%defparameter form env source))
+            ((%defvar %defvar-init) (fcomp-load-defvar form env source))
+            ((%defun) (fcomp-load-%defun form env source))
             ((set-package %define-package)
-             (fcomp-random-toplevel-form form env)
+             (fcomp-random-toplevel-form form env source)
              (fcomp-compile-toplevel-forms env))
-            ((%macro) (fcomp-load-%macro form env))
-            ;; ((%deftype) (fcomp-load-%deftype form))
-            ;; ((define-setf-method) (fcomp-load-define-setf-method form))
-            (t (fcomp-random-toplevel-form form env)))))))))
-
-(defun fcomp-form-list (forms env processing-mode)
-  (dolist (form forms) (fcomp-form form env processing-mode)))
-
-(defun fcomp-compiler-let (form env processing-mode &aux vars varinits)
+            ((%macro) (fcomp-load-%macro form env source))
+            ;; ((%deftype) (fcomp-load-%deftype form source))
+            ;; ((define-setf-method) (fcomp-load-define-setf-method form source))
+            (t (fcomp-random-toplevel-form form env source)))))))))
+
+(defun fcomp-form-list (forms env processing-mode source)
+  (dolist (form forms) (fcomp-form form env processing-mode source)))
+
+(defun fcomp-compiler-let (form env processing-mode source &aux vars varinits)
   (fcomp-compile-toplevel-forms env)
   (dolist (pair (pop form))
@@ -522,15 +555,15 @@
     (push (%compile-time-eval (nx-pair-initform pair) env) varinits))
   (progv (nreverse vars) (nreverse varinits)
-                 (fcomp-form-list form env processing-mode)
+                 (fcomp-form-list form env processing-mode source)
                  (fcomp-compile-toplevel-forms env)))
 
-(defun fcomp-locally (body env processing-mode)
+(defun fcomp-locally (body env processing-mode source)
   (fcomp-compile-toplevel-forms env)
   (multiple-value-bind (body decls) (parse-body body env)
     (let* ((env (augment-environment env :declare (decl-specs-from-declarations decls))))
-      (fcomp-form-list body env processing-mode)
+      (fcomp-form-list body env processing-mode source)
       (fcomp-compile-toplevel-forms env))))
 
-(defun fcomp-macrolet (body env processing-mode)
+(defun fcomp-macrolet (body env processing-mode source)
   (fcomp-compile-toplevel-forms env)
   (let ((outer-env (augment-environment env 
@@ -545,8 +578,8 @@
                    outer-env
                    :declare (decl-specs-from-declarations decls))))
-        (fcomp-form-list body env processing-mode)
+        (fcomp-form-list body env processing-mode source)
         (fcomp-compile-toplevel-forms env)))))
 
-(defun fcomp-symbol-macrolet (body env processing-mode)
+(defun fcomp-symbol-macrolet (body env processing-mode source)
   (fcomp-compile-toplevel-forms env)
   (let* ((outer-env (augment-environment env :symbol-macro (car body))))
@@ -554,8 +587,8 @@
       (let* ((env (augment-environment outer-env 
                                        :declare (decl-specs-from-declarations decls))))
-        (fcomp-form-list body env processing-mode)
+        (fcomp-form-list body env processing-mode source)
         (fcomp-compile-toplevel-forms env)))))
-                                                               
-(defun fcomp-eval-when (form env processing-mode &aux (eval-times (pop form)))
+
+(defun fcomp-eval-when (form env processing-mode source &aux (eval-times (pop form)))
   (let* ((compile-time-too  (eq processing-mode :compile-time-too))
          (compile-time-only (eq processing-mode :compile-time))
@@ -574,11 +607,11 @@
     (fcomp-compile-toplevel-forms env)        ; always flush the suckers
     (cond (compile-time-only
-           (if at-eval-time (fcomp-form-list form env :compile-time)))
+           (if at-eval-time (fcomp-form-list form env :compile-time source)))
           (at-load-time
            (fcomp-form-list form env (if (or at-compile-time (and at-eval-time compile-time-too))
                                        :compile-time-too
-                                       :not-compile-time)))
+                                       :not-compile-time) source))
           ((or at-compile-time (and at-eval-time compile-time-too))
-           (fcomp-form-list form env :compile-time))))
+           (fcomp-form-list form env :compile-time source))))
   (fcomp-compile-toplevel-forms env))
 
@@ -609,5 +642,5 @@
     symbol))
 
-(defun fcomp-load-%defconstant (form env)
+(defun fcomp-load-%defconstant (form env source)
   (destructuring-bind (sym valform &optional doc) (cdr form)
     (unless *fasl-save-doc-strings*
@@ -617,7 +650,7 @@
     (if (and (typep sym 'symbol) (or  (quoted-form-p valform) (self-evaluating-p valform)))
       (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc))
-      (fcomp-random-toplevel-form form env))))
-
-(defun fcomp-load-%defparameter (form env)
+      (fcomp-random-toplevel-form form env source))))
+
+(defun fcomp-load-%defparameter (form env source)
   (destructuring-bind (sym valform &optional doc) (cdr form)
     (unless *fasl-save-doc-strings*
@@ -628,5 +661,5 @@
       (if (and (typep sym 'symbol) (or fn (constantp valform)))
         (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc))
-        (fcomp-random-toplevel-form form env)))))
+        (fcomp-random-toplevel-form form env source)))))
 
 ; Both the simple %DEFVAR and the initial-value case (%DEFVAR-INIT) come here.
@@ -635,5 +668,5 @@
 ; Hairier initforms could be handled by another fasl operator that takes a thunk
 ; and conditionally calls it.
-(defun fcomp-load-defvar (form env)
+(defun fcomp-load-defvar (form env source)
   (destructuring-bind (sym &optional (valform nil val-p) doc) (cdr form)
     (unless *fasl-save-doc-strings*
@@ -647,5 +680,5 @@
           (if (and sym-p (or fn (constantp valform)))
             (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc))
-            (fcomp-random-toplevel-form (macroexpand-1 form env) env)))))))
+            (fcomp-random-toplevel-form (macroexpand-1 form env) env source)))))))
       
 (defun define-compile-time-macro (name lambda-expression env)
@@ -654,5 +687,5 @@
       (push (list* name 
                    'macro 
-                   (compile-named-function lambda-expression name env)) 
+                   (compile-named-function lambda-expression :name name :env env))
             (defenv.functions definition-env)))
     name))
@@ -722,5 +755,5 @@
          )))))
 
-(defun fcomp-load-%defun (form env)
+(defun fcomp-load-%defun (form env source)
   (destructuring-bind (fn &optional doc) (cdr form)
     (unless *fasl-save-doc-strings*
@@ -730,18 +763,18 @@
         (setq doc nil)))
     (if (and (constantp doc)
-             (setq fn (fcomp-function-arg fn env)))
+             (setq fn (fcomp-function-arg fn env source)))
       (progn
         (setq doc (eval-constant doc))
         (fcomp-output-form $fasl-defun env fn doc))
-      (fcomp-random-toplevel-form form env))))
-
-(defun fcomp-load-%macro (form env &aux fn doc)
+      (fcomp-random-toplevel-form form env source))))
+
+(defun fcomp-load-%macro (form env source &aux fn doc)
   (verify-arg-count form 1 2)
   (if (and (constantp (setq doc (caddr form)))
-           (setq fn (fcomp-function-arg (cadr form) env)))
+           (setq fn (fcomp-function-arg (cadr form) env source)))
     (progn
       (setq doc (eval-constant doc))
       (fcomp-output-form $fasl-macro env fn doc))
-    (fcomp-random-toplevel-form form env)))
+    (fcomp-random-toplevel-form form env source)))
 
 (defun define-compile-time-structure (sd refnames predicate env)
@@ -766,5 +799,5 @@
   (nx-transform form env))
 
-(defun fcomp-random-toplevel-form (form env)
+(defun fcomp-random-toplevel-form (form env source)
   (unless (constantp form)
     (unless (or (atom form)
@@ -778,5 +811,5 @@
         (while args
           (multiple-value-bind (arg win) (fcomp-transform (%car args) env)
-            (when (or (setq lfun (fcomp-function-arg arg env))
+            (when (or (setq lfun (fcomp-function-arg arg env source))
                       win)
               (when lfun (setq arg `',lfun))
@@ -788,13 +821,13 @@
     (push form *fcomp-toplevel-forms*)))
 
-(defun fcomp-function-arg (expr env)
+(defun fcomp-function-arg (expr env &optional source)
   (when (consp expr)
-    (if (and (eq (%car expr) 'nfunction)
-             (symbolp (car (%cdr expr)))
-             (lambda-expression-p (car (%cddr expr))))
-      (fcomp-named-function (%caddr expr) (%cadr expr) env)
-      (if (and (eq (%car expr) 'function)
-               (lambda-expression-p (car (%cdr expr))))
-        (fcomp-named-function (%cadr expr) nil env)))))
+    (cond ((and (eq (%car expr) 'nfunction)
+                (symbolp (car (%cdr expr)))
+                (lambda-expression-p (car (%cddr expr))))
+           (fcomp-named-function (%caddr expr) (%cadr expr) env source))
+          ((and (eq (%car expr) 'function)
+                (lambda-expression-p (car (%cdr expr))))
+           (fcomp-named-function (%cadr expr) nil env source)))))
 
 (defun fcomp-compile-toplevel-forms (env)
@@ -835,15 +868,17 @@
 ;;; file.  The result will not be funcalled.  This really shouldn't bother
 ;;; making an lfun, but it's simpler this way...
-(defun fcomp-named-function (def name env)
+(defun fcomp-named-function (def name env &optional source)
   (let* ((env (new-lexical-environment env)))
     (multiple-value-bind (lfun warnings)
-                         (compile-named-function
-                          def name
-                          env
-                          *fasl-save-definitions*
-                          *fasl-save-local-symbols*
-                          *default-file-compilation-policy*
-                          cfasl-load-time-eval-sym
-			  *fasl-target*)
+                         (compile-named-function def
+                                                 :name name
+                                                 :env env
+                                                 :source source
+                                                 :keep-lambda *fasl-save-definitions*
+                                                 :keep-symbols *fasl-save-local-symbols*
+                                                 :policy *default-file-compilation-policy*
+                                                 :source-locations *fcomp-source-note-map*
+                                                 :load-time-eval-token cfasl-load-time-eval-sym
+                                                 :target *fasl-target*)
       (fcomp-signal-or-defer-warnings warnings env)
       lfun)))
@@ -1083,5 +1118,5 @@
                                              (or
                                               (gethash load-form *make-load-form-hash*)
-                                              (fcomp-named-function `(lambda () ,load-form) nil nil))
+                                              (fcomp-named-function `(lambda () ,load-form) nil nil nil))
                           (when warnings
                             (cerror "Ignore the warnings"
Index: /branches/gz-working/lib/read.lisp
===================================================================
--- /branches/gz-working/lib/read.lisp	(revision 8437)
+++ /branches/gz-working/lib/read.lisp	(revision 8438)
@@ -46,7 +46,4 @@
                (cons form (read-file-to-list-aux stream))))))
 |#
-
-(defun read-internal (input-stream)
-  (read input-stream t nil t))
 
 
@@ -96,7 +93,7 @@
           (signal-reader-error stream "reader macro #A used without a rank integer"))
          ((eql dimensions 0) ;0 dimensional array
-          (make-array nil :initial-contents (read-internal stream)))
+          (make-array nil :initial-contents (read-internal stream t nil t)))
          ((and (integerp dimensions) (> dimensions 0)) 
-          (let ((init-list (read-internal stream)))
+          (let ((init-list (read-internal stream t nil t)))
             (cond ((not (typep init-list 'sequence))
                    (signal-reader-error stream "The form following a #~SA reader macro should have been a sequence, but it was: ~S" dimensions init-list))
@@ -130,5 +127,5 @@
   (qlfun |#S-reader| (input-stream sub-char int &aux list sd)
      (declare (ignore sub-char int))
-     (setq list (read-internal input-stream))
+     (setq list (read-internal input-stream t nil t))
      (unless *read-suppress*
        (unless (and (consp list)
Index: /branches/gz-working/library/lispequ.lisp
===================================================================
--- /branches/gz-working/library/lispequ.lisp	(revision 8437)
+++ /branches/gz-working/library/lispequ.lisp	(revision 8438)
@@ -139,5 +139,5 @@
 (defconstant $lfbits-aok-bit 16)
 (defconstant $lfbits-numinh (byte 6 17))
-(defconstant $lfbits-symmap-bit 23)
+(defconstant $lfbits-info-bit 23)
 (defconstant $lfbits-trampoline-bit 24)
 (defconstant $lfbits-evaluated-bit 25)