Index: /branches/gz-working/compiler/PPC/ppc2.lisp
===================================================================
--- /branches/gz-working/compiler/PPC/ppc2.lisp	(revision 8504)
+++ /branches/gz-working/compiler/PPC/ppc2.lisp	(revision 8505)
@@ -497,6 +497,6 @@
                             (if (and fname (symbolp fname)) (symbol-name fname)))))
                    (ppc2-digest-symbols)
-                   (ppc2-digest-source-notes))))
-          (ppc2-reset-source-notes)
+                   (ppc2-digest-code-notes))))
+          (ppc2-reset-code-notes)
           (backend-remove-labels))))
     afunc))
@@ -2156,7 +2156,7 @@
         (! vpop-register ppc::arg_x)))))
 
-(defppc2 ppc2-with-source-note with-source-note (seg vreg xfer note form &aux val)
+(defppc2 ppc2-with-code-note with-code-note (seg vreg xfer note form &aux val)
   (when *record-pc-mapping*
-    (append-dll-node (setf (source-note-start-pc note) (make-vinsn-label nil)) seg))
+    (append-dll-node (setf (code-note-start-pc note) (make-vinsn-label nil)) seg))
   (when *compile-code-coverage*
     (let ((afunc *ppc2-cur-afunc*))
@@ -2167,8 +2167,8 @@
   (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))
+    (append-dll-node (setf (code-note-end-pc note) (make-vinsn-label nil)) seg))
   val)
 
-(defun ppc2-digest-source-notes ()
+(defun ppc2-digest-code-notes ()
   (when (or *compile-code-coverage* *record-pc-mapping*)
     (flet ((address (label)
@@ -2179,17 +2179,17 @@
       (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)))))
+                   (setf (code-note-start-pc note) (address (code-note-start-pc note)))
+                   (setf (code-note-end-pc note) (address (code-note-end-pc note)))
+                   (dolist (subnote (code-note-subform-notes note)) (rec subnote)))))
         (rec (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))))))
 
-(defun ppc2-reset-source-notes ()
+(defun ppc2-reset-code-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)))))
+                   (setf (code-note-start-pc note) (clear (code-note-start-pc note)))
+                   (setf (code-note-end-pc note) (clear (code-note-end-pc note)))
+                   (dolist (subnote (code-note-subform-notes note)) (rec subnote)))))
         (rec (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))))))
 
Index: /branches/gz-working/compiler/nx.lisp
===================================================================
--- /branches/gz-working/compiler/nx.lisp	(revision 8504)
+++ /branches/gz-working/compiler/nx.lisp	(revision 8505)
@@ -154,41 +154,57 @@
 
 (defun note-contained-in-p (note parent)
-  (loop for n = note then (source-note-source n) while (source-note-p n) thereis (eq n parent)))
-
-(defun nx-ensure-source-note (form parent-note)
-  ;; Try to find a source note for this form; if the form doesn't come from user source, just make
-  ;; a new record for it.  The act of matching up a source note with forms that might come from
-  ;; macroexpansion is heuristic at best.  In general, err in favor of making a new record, because
-  ;; that leads to fewer false positives in code coverage reporting.  But still, try hard to
-  ;; match things up best we can.  The main problem is with atoms, which the source recording stuff
-  ;; doesn't track properly.
-  (let ((note (gethash form *nx-source-note-map*)))
-    (when note
-      (let* ((parent-source (loop for n = parent-note then (source-note-source n)
-                              when (or (null n) (source-note-start-pos n)) return n)))
-        (setq note
-              (when parent-source
-                (if (consp note)
-                  ;; This form (typically an atom) has multiple source locations.
-                  ;; At least try to distinguish occurences in different outer forms.  This allows
-                  ;; reasonable code coverage reporting for "(if (test) t (other))", although it
-                  ;; doesn't work for cases like "(if foo foo (other))".
-                  (loop with found = nil
-                    for n in note
-                    when (note-contained-in-p n parent-source)
-                    do (if found (return nil) (setq found n))
-                    finally (return found))
-                  (when (note-contained-in-p note parent-source)
-                    ;; As an aside, here's a fun code coverage issue:  What if the same source
-                    ;; form (i.e. single source location) 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.
-                    note))))))
-    (unless note
-      (setq note (make-source-note :form form :source parent-note)))
+  (loop for n = note then (code-note-source n) while (code-note-p n) thereis (eq n parent)))
+
+(defun nx-find-code-note (form parent-source)
+  ;; Try to find a source note for this form.  The act of matching up a source note with
+  ;; forms that might come from macroexpansion is heuristic at best.  In general, err in
+  ;; favor of not matching, because that leads to fewer false positives in code coverage
+  ;; reporting.  But still, try hard to match things up best we can.  The main problem is
+  ;; with atoms, which the source recording stuff doesn't track properly.
+  #| -- This doesn't work, period, it leads to too many false positives.  The problem
+    -- is that even if we have just one instance of the form in the parent source,
+    -- there might be many generated occurences that do NOT correspond to the one
+    -- in the source, and the form can be one of those, leading to false positives on the
+    -- source version.
+  (when parent-source
+    (let ((note (gethash form *nx-source-note-map*)))
+      (cond ((consp note)
+             ;; This form (typically an atom) has multiple source locations.
+             ;; At least try to distinguish occurences in different outer forms.  This allows
+             ;; reasonable code coverage reporting for "(if (test) t (other))", although it
+             ;; doesn't work for cases like "(if foo foo (other))".
+             (loop with found = nil
+               for n in note
+               ;; I tried allowing parent-source to be an indirect ancestor, but that would
+               ;; catch unrelated references in outer forms.
+               when (eq (code-note-source n) parent-source)
+               do (if found (return nil) (setq found n))
+               finally (return found)))
+            ((not (null note))
+             (when (note-contained-in-p note parent-source)
+               ;; As an aside, here's a fun code coverage issue:  What if the same source
+               ;; form (i.e. single source location) 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.
+               note))
+            (t nil))))
+  |#
+  (when (and parent-source
+             (or (consp form) (vectorp form) (pathnamep form)))
+    (let ((note (gethash form *nx-source-note-map*)))
+      (unless (listp note)
+        note))))
+
+(defun nx-ensure-code-note (form original parent-note)
+  ;; Try to find a source note for this form; if can't, just make a new record for it.
+  (let* ((parent-source (loop for n = parent-note then (code-note-source n)
+                          when (or (null n) (source-note-p n)) return n))
+         (note (or (and original (nx-find-code-note original parent-source))
+                   (nx-find-code-note form parent-source)
+                   (make-code-note :form (or original form) :source parent-note))))
     (when (and parent-note (neq note parent-note))
-      (push note (source-note-subform-notes parent-note)))
+      (push note (code-note-subform-notes parent-note)))
     note))
 
@@ -214,5 +230,5 @@
                                 :target target))))
 
-(defun compile-named-function-1 (def &key name env source-note keep-lambda keep-symbols policy load-time-eval-token target source-locations)
+(defun compile-named-function-1 (def &key name env function-note keep-lambda keep-symbols policy load-time-eval-token target source-notes)
   (when (and name *nx-discard-xref-info-hook*)
     (funcall *nx-discard-xref-info-hook* name))
@@ -220,5 +236,5 @@
    def
    (let ((*load-time-eval-token* load-time-eval-token)
-         (*nx-source-note-map* source-locations)
+         (*nx-source-note-map* source-notes)
          (env (new-lexical-environment env)))
      (setf (lexenv.variables env) 'barrier)
@@ -232,5 +248,5 @@
                       (or policy *default-compiler-policy*)
                       *load-time-eval-token*
-                      source-note)))
+                      function-note)))
          (if (afunc-lfun afunc)
            afunc
Index: /branches/gz-working/compiler/nx0.lisp
===================================================================
--- /branches/gz-working/compiler/nx0.lisp	(revision 8504)
+++ /branches/gz-working/compiler/nx0.lisp	(revision 8505)
@@ -78,5 +78,5 @@
 (defvar *nx-operators* ())
 (defvar *nx-warnings* nil)
-(defvar *nx-current-source-note* nil)
+(defvar *nx-current-code-note* nil)
 
 
@@ -1254,5 +1254,5 @@
                                  (policy *default-compiler-policy*)
                                  load-time-eval-token
-                                 source-note)
+                                 code-note)
   (if q
      (setf (afunc-parent p) q))
@@ -1287,5 +1287,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 source-note))
+      (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls code-note))
       (nx1-transitively-punt-bindings *nx-punted-vars*)
       (setf (afunc-blocks p) *nx-blocks*)
@@ -1310,11 +1310,11 @@
 
 
-(defun nx1-lambda (ll body decls &optional source-note &aux (l ll) methvar)
-  (when source-note
+(defun nx1-lambda (ll body decls &optional code-note &aux (l ll) methvar)
+  (when code-note
     (setf (afunc-lfun-info *nx-current-function*)
-          (list* 'function-source-note source-note (afunc-lfun-info *nx-current-function*))))
+          (list* 'function-source-note code-note (afunc-lfun-info *nx-current-function*))))
   (let* ((old-env *nx-lexical-environment*)
          (*nx-bound-vars* *nx-bound-vars*)
-         (*nx-current-source-note* (and (or *compile-code-coverage* *record-pc-mapping*) source-note)))
+         (*nx-current-code-note* (and (or *compile-code-coverage* *record-pc-mapping*) code-note)))
 
     (with-nx-declarations (pending)
@@ -1572,11 +1572,13 @@
 
 (defun nx1-transformed-form (form env &optional original)
-  (if *nx-current-source-note*
-    (let* ((original (or original form))
-           (new-note (nx-ensure-source-note original *nx-current-source-note*))
-           (*nx-current-source-note* new-note))
+  (if *nx-current-code-note*
+    ;; It is possible for the form to be a source form when the original is not: macros
+    ;; often insert wrappings, e.g. (when (foo) (bar)) becomes (IF (foo) (PROGN (bar))),
+    ;; and (PROGN (bar)) transforms into (bar), which is a source form.
+    (let* ((new-note (nx-ensure-code-note form original *nx-current-code-note*))
+           (*nx-current-code-note* new-note))
       (unless new-note
         (compiler-bug "No source note for ~s -> ~s" original form))
-      (make-acode (%nx1-operator with-source-note)
+      (make-acode (%nx1-operator with-code-note)
 		  new-note
                   (nx1-transformed-form-aux form env)))
@@ -2001,8 +2003,11 @@
 
 (defun nx-transform (form &optional (environment *nx-lexical-environment*))
-  (let* (sym transforms lexdefs changed enabled macro-function compiler-macro)
+  (let* (sym transforms lexdefs changed enabled macro-function compiler-macro source)
+    (when (or (null *nx-source-note-map*) (gethash form *nx-source-note-map*))
+      (setq source t))
     (tagbody
        (go START)
      LOOP
+       (unless source (setq source (gethash form *nx-source-note-map*)))
        (setq changed t)
        (when (and (consp form) 
@@ -2014,5 +2019,5 @@
 	 (multiple-value-bind (newform win) (nx-transform-symbol form environment)
 	   (unless win (go DONE))
-	   (setq form newform changed (or changed win))
+	   (setq form newform)
 	   (go LOOP)))
        (when (atom form) (go DONE))
@@ -2023,8 +2028,9 @@
            (if (constantp thing)
              (progn
-               (setq form thing form thing)
+               (setq form thing)
                (go LOOP))
              (multiple-value-bind (newform win) (nx-transform thing environment)
                (when win
+                 (unless source (setq source (gethash newform *nx-source-note-map*)))
                  (setq changed t)
                  (if (and (self-evaluating-p newform)
@@ -2047,9 +2053,14 @@
 	   (when (and enabled (functionp (fboundp sym)))
 	     (multiple-value-setq (form win) (nx-transform-arglist form environment))
-	     (if win (setq changed t)))))
+	     (when win
+               (unless source (setq source (gethash form *nx-source-note-map*)))
+               (setq changed t)))))
        (when (and enabled
 		  (not (nx-declared-notinline-p sym environment)))
 	 (multiple-value-bind (value folded) (nx-constant-fold form environment)
-	   (when folded (setq form value changed t)  (unless (and (consp form) (eq (car form) sym)) (go START))))
+	   (when folded
+             (setq form value changed t)
+             (unless source (setq source (gethash form *nx-source-note-map*)))
+             (unless (and (consp form) (eq (car form) sym)) (go START))))
 	 (when compiler-macro
 	   (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment)
@@ -2068,5 +2079,6 @@
 				      (and #-bccl (boundp '%structure-refs%)
 					   (gethash sym %structure-refs%))))
-	     (setq form (defstruct-ref-transform transforms (%cdr form)) changed T)
+	     (setq form (defstruct-ref-transform transforms (%cdr form)) changed t)
+             (unless source (setq source (gethash form *nx-source-note-map*)))
 	     (go START))
 	   (when (setq transforms (assq sym *nx-synonyms*))
@@ -2078,6 +2090,10 @@
 	 (nx-record-xref-info :macro-calls (function-name macro-function))
 	 (setq form (macroexpand-1 form environment) changed t)
+         (unless source (setq source (gethash form *nx-source-note-map*)))
 	 (go START))
      DONE)
+    (when (and source (neq source t) (not (gethash form *nx-source-note-map*)))
+      ;; Neither the initial nor final form has source, but somewhere in the middle we encountered one.
+      (setf (gethash form *nx-source-note-map*) source))
     (values form changed)))
 
Index: /branches/gz-working/compiler/nxenv.lisp
===================================================================
--- /branches/gz-working/compiler/nxenv.lisp	(revision 8504)
+++ /branches/gz-working/compiler/nxenv.lisp	(revision 8505)
@@ -413,5 +413,5 @@
      (%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))
-     (with-source-note . #.(logior operator-assignment-free-mask)))))
+     (with-code-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 8504)
+++ /branches/gz-working/level-1/l1-reader.lisp	(revision 8505)
@@ -2982,20 +2982,16 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(defstruct (source-note (:constructor %make-source-note))
+(defstruct (code-note (:constructor %make-code-note))
   ;; Code coverage state.  This MUST be the first slot - see nx2-code-coverage.
   code-coverage
-  ;; The actual form
+  ;; The actual form - useful during debugging, perhaps remove later.
   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.
+  ;; For a random code form (no file info, generated by macros or other source
+  ;; transform), code-note of parent 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.
+  ;; an lfun, it could contain intermediate results during compilation.
   start-pc
   end-pc
@@ -3003,14 +2999,22 @@
   subform-notes)
 
-(defmethod make-load-form ((note source-note) &optional env)
+(defstruct (source-note (:include code-note)
+			(:constructor %make-source-note))
+  ;; The source location: file name, and start/end offsets within the file
+  file-name
+  start-pos
+  end-pos)
+
+
+(defmethod make-load-form ((note code-note) &optional env)
   (make-load-form-saving-slots note :environment env))
 
-(defmethod print-object ((note source-note) stream)
+(defmethod print-object ((note code-note) stream)
   (print-unreadable-object (note stream :type t :identity t)
-    (let ((text (ignore-errors (source-note-text note))))
+    (let ((text (and (source-note-p note) (ignore-errors (source-note-text note)))))
       (when (null text)
         (setq text (ignore-errors
                     (let ((*print-circle* t))
-                      (format nil "~s" (source-note-form note))))))
+                      (format nil "~s" (code-note-form note))))))
       (when (> (length text) 20)
         (let ((end (position #\Newline text :start 20)))
@@ -3019,8 +3023,8 @@
                                     (subseq text 0 (min (or end (length text)) 120))
                                     "...")))))
-      (format stream "[~s] for ~s (~s subforms)"
-              (source-note-code-coverage note)
+      (format stream "[~s]~:[~;for ~:*~a~] (~s subforms)"
+              (code-note-code-coverage note)
               text
-              (length (source-note-subform-notes note))))))
+              (length (code-note-subform-notes note))))))
 
 (defun source-note-length (note)
@@ -3034,16 +3038,17 @@
 (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))
-          ((source-note-p source)
-           (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)))))))))
+  (when (source-note-p note)
+    (let ((source (source-note-source note)))
+      (cond ((stringp source)
+             (assert (<= (source-note-length note) (length source)))
+             (values source 0))
+            ((source-note-p source)
+             (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* ())
@@ -3079,38 +3084,37 @@
                                               :end-pos (+ (or start-offset 0) (file-position stream)))))))))
 
-(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* ((prev (gethash form map))
-                 (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)
-                  (cond ((null prev) note)
-                        ((consp prev) (cons note prev))
-                        (t (list note prev))))
-            (loop for sub in subform-notes as subnote = (require-type sub 'source-note)
-              do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote))
-              do (setf (source-note-source subnote) note))
-            note))))
-    ;; Else note for a form generated by macroexpansion
-    (let* ((source (and source (require-type source 'source-note)))
-           (note (%make-source-note
-                  ;; Unfortunately, recording the macroexpanded form is problematic, since they
-                  ;; can have references to non-dumpable forms, see e.g. loop.
-                  ;; Could print it with *print-string-length* bound to 80 or so, and record
-                  ;; the string instead.
-                  ;; :form form
-                  :source source)))
-      ;; For debugging
-      #+gz (setf (source-note-form note)
-                 (with-output-to-string (s) (let ((*print-string-length* 80)) (prin1 form s))))
-      note)))
+(defun make-source-note (&key form stream start-pos end-pos subform-notes)
+  (let ((recording (assoc stream *recording-source-streams*)))
+    (when (and recording (not *read-suppress*))
+      (destructuring-bind (map file-name stream-offset) (cdr recording)
+        (let* ((prev (gethash form map))
+               (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)
+                (cond ((null prev) note)
+                      ((consp prev) (cons note prev))
+                      (t (list note prev))))
+          (loop for sub in subform-notes as subnote = (require-type sub 'source-note)
+            do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote))
+            do (setf (source-note-source subnote) note))
+          note)))))
+
+(defun make-code-note (&key form source)
+  (declare (ignorable form))
+  ;; A note for a form generated by macroexpansion
+  (let* ((source (and source (require-type source 'code-note)))
+         (note (%make-code-note
+                ;; Unfortunately, recording the macroexpanded form is problematic, since they
+                ;; can have references to non-dumpable forms, see e.g. loop.
+                ;; Could print it and record the string instead.
+                ;; :form form
+                :source source)))
+    #+debug
+    (when form
+      (setf (code-note-form note)
+            (with-output-to-string (s) (let ((*print-string-length* 80)) (prin1 form s)))))
+    note))
 
 ; end
Index: /branches/gz-working/lib/compile-ccl.lisp
===================================================================
--- /branches/gz-working/lib/compile-ccl.lisp	(revision 8504)
+++ /branches/gz-working/lib/compile-ccl.lisp	(revision 8505)
@@ -194,4 +194,5 @@
 	edit-callers
         describe
+        cover
 	asdf
 	defsystem
Index: /branches/gz-working/lib/nfcomp.lisp
===================================================================
--- /branches/gz-working/lib/nfcomp.lisp	(revision 8504)
+++ /branches/gz-working/lib/nfcomp.lisp	(revision 8505)
@@ -436,4 +436,7 @@
                                 (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
                                 (signal c))))
+		  (when *fcomp-source-note-map*
+		    ;; Hack to keep from sharing inline function source notes...
+		    (clrhash *fcomp-source-note-map*))
                   (multiple-value-setq (form source-note)
                     (read-recording-source stream
@@ -833,6 +836,5 @@
   (when (consp expr)
     (cond ((and (eq (%car expr) 'nfunction)
-                (symbolp (car (%cdr expr)))
-                (lambda-expression-p (car (%cddr expr))))
+                (lambda-expression-p (cadr (%cdr expr))))
            (fcomp-named-function (%caddr expr) (%cadr expr) env source-note))
           ((and (eq (%car expr) 'function)
@@ -883,9 +885,9 @@
                                                  :name name
                                                  :env env
-                                                 :source-note source-note
+                                                 :function-note source-note
                                                  :keep-lambda *fasl-save-definitions*
                                                  :keep-symbols *fasl-save-local-symbols*
                                                  :policy *default-file-compilation-policy*
-                                                 :source-locations *fcomp-source-note-map*
+                                                 :source-notes *fcomp-source-note-map*
                                                  :load-time-eval-token cfasl-load-time-eval-sym
                                                  :target *fasl-target*)
Index: /branches/gz-working/library/cover.lisp
===================================================================
--- /branches/gz-working/library/cover.lisp	(revision 8505)
+++ /branches/gz-working/library/cover.lisp	(revision 8505)
@@ -0,0 +1,365 @@
+;;; Code coverage reporting facility, based on the SBCL's
+;;; sb-cover written by Juho Snellman, and placed under public domain.
+;;; Port to ccl by gz@clozure.com
+
+(in-package :ccl)
+
+(export '(*compile-code-coverage*
+          report-coverage
+          reset-coverage
+          clear-coverage
+          save-coverage-in-file
+          restore-coverage-from-file))
+
+(defconstant $not-executed-style 2)
+(defconstant $totally-covered-style 5)
+(defconstant $partially-covered-style 6)
+
+(defun show-notes (note)
+  (when (functionp note)
+    (setq note (function-source-note note)))
+  (labels ((show (note indent label)
+             (dotimes (i indent) (write-char #\space))
+             (format t "~a ~a~%" label note)
+             (loop with subindent = (+ indent 3)
+               for sub in (code-note-subform-notes note) as i upfrom 1
+               do (show sub subindent (format nil "~a~d." label i)))))
+    (show note 0 "")))
+
+(defun covered-functions-for-file (path)
+  (let* ((true-path (probe-file path))
+         (data (find-if #'(lambda (data)
+                           (and (consp data)
+                                (equalp (probe-file (car data)) true-path)))
+                       *code-covered-functions*)))
+    (cdr data)))
+
+(defun map-covered-functions (fn)
+  (loop for data in *code-covered-functions*
+    do (typecase data
+         (cons ;; (source-file . functions)
+          (map nil fn (cdr data)))
+         (function
+          (funcall fn data)))))
+
+(defun map-coverage-records (fn)
+  (map-covered-functions #'(lambda (function)
+                             (labels ((rec (note)
+                                        (when note
+                                          (map nil #'rec (code-note-subform-notes note))
+                                          (funcall fn note))))
+                               (rec (function-source-note function))))))
+
+(defun clear-coverage ()
+  "Clear all files from the coverage database. The files will be re-entered
+into the database when the FASL files (produced by compiling with
+CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the
+image."
+  (setq *code-covered-functions* nil))
+
+(defun reset-coverage ()
+  "Reset all coverage data back to the `Not executed` state."
+  (map-coverage-records #'(lambda (note)
+                            (setf (code-note-code-coverage note) nil))))
+
+(defun save-coverage ()
+  "Returns an opaque representation of the current code coverage state.
+The only operation that may be done on the state is passing it to
+RESTORE-COVERAGE. The representation is guaranteed to be readably printable.
+A representation that has been printed and read back will work identically
+in RESTORE-COVERAGE."
+  #+sbcl(loop for file being the hash-keys of sb-c::*code-coverage-info*
+	   using (hash-value states)
+	   collect (cons file states))
+  (error "Not implemented yet"))
+
+(defun restore-coverage (coverage-state)
+  "Restore the code coverage data back to an earlier state produced by
+SAVE-COVERAGE."
+  #+sbcl
+  (loop for (file . states) in coverage-state
+        do (let ((image-states (gethash file sb-c::*code-coverage-info*))
+                 (table (make-hash-table :test 'equal)))
+             (when image-states
+               (loop for cons in image-states
+                     do (setf (gethash (car cons) table) cons))
+               (loop for (key . value) in states
+                     do (let ((state (gethash key table)))
+                          (when state
+                            (setf (cdr state) value)))))))
+  coverage-state
+  (error "Not implemented yet"))
+
+(defun save-coverage-in-file (pathname)
+  "Call SAVE-COVERAGE and write the results of that operation into the
+file designated by PATHNAME."
+  (with-open-file (stream pathname
+                          :direction :output
+                          :if-exists :supersede
+                          :if-does-not-exist :create)
+    (with-standard-io-syntax
+      (let ((*package* (find-package :sb-cover)))
+        (write (save-coverage) :stream stream)))
+    (values)))
+
+(defun restore-coverage-from-file (pathname)
+  "READ the contents of the file designated by PATHNAME and pass the
+result to RESTORE-COVERAGE."
+  (with-open-file (stream pathname :direction :input)
+    (with-standard-io-syntax
+      (let ((*package* (find-package :sb-cover)))
+        (restore-coverage (read stream))))
+    (values)))
+
+(defun common-coverage-directory ()
+  (let* ((host :unknown)
+	 (rev-dir ()))
+    (loop for data in *code-covered-functions*
+       when (consp data)
+       do (let ((file (probe-file (car data))))
+	    (when file
+	      (cond ((eq host :unknown)
+		     (setq host (pathname-host file)
+			   rev-dir (reverse (pathname-directory file))))
+		    ((not (equalp host (pathname-host file)))
+		     (return-from common-coverage-directory nil))
+		    (t
+		     (let* ((path (pathname-directory file))
+			    (dir-len (length rev-dir))
+			    (len (length path)))
+		       (if (< len dir-len)
+			 (setq rev-dir (nthcdr (- dir-len len) rev-dir))
+			 (setq path (subseq path 0 dir-len)))
+		       (loop for pp on (reverse path) until (equalp pp rev-dir)
+			  do (pop rev-dir))))))))
+    (unless (eq host :unknown)
+      (make-pathname :host host :directory (reverse rev-dir)))))
+
+
+(defun report-coverage (output-file &key (external-format :default))
+  "Print a code coverage report of all instrumented files into DIRECTORY.
+If DIRECTORY does not exist, it will be created. The main report will be
+printed to the file cover-index.html. The external format of the source
+files can be specified with the EXTERNAL-FORMAT parameter.
+"
+  (let* ((paths)
+         (directory (make-pathname :name nil :type nil :defaults output-file))
+         (coverage-dir (common-coverage-directory)))
+    (ensure-directories-exist directory)
+    (loop for data in *code-covered-functions*
+      as file = (and (consp data)
+                     (or (probe-file (car data))
+                         (progn (warn "Cannot find ~s" (car data)) nil)))
+      do (when file
+           (let* ((src-name (enough-namestring file coverage-dir))
+                  (html-name (substitute #\_ #\: (substitute #\_ #\. (substitute #\_ #\/ src-name)))))
+             (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
+                                     :direction :output
+                                     :if-exists :supersede
+                                     :if-does-not-exist :create)
+               (report-file-coverage file (cdr data) stream external-format))
+             (push (list* src-name html-name (cdr data)) paths))))
+    (setq paths (sort paths #'string< :key #'car))
+    (when (null paths)
+      (error "No code coverage data available"))
+    (let ((index-file (merge-pathnames output-file "index.html")))
+      (with-open-file (stream index-file
+                              :direction :output
+                              :if-exists :supersede
+                              :if-does-not-exist :create)
+        (write-coverage-styles stream)
+        (unless paths
+          (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?")
+          (format stream "<h3>No code coverage data found.</h3>")
+          (return-from report-coverage))
+        (format stream "<table class='summary'>")
+        (coverage-stats-head-html stream)
+        (loop for prev = nil then source-file
+          for (source-file report-name . functions) in paths
+          for even = nil then (not even)
+          do (when (or (null prev)
+                       (not (equal (pathname-directory (pathname source-file))
+                                   (pathname-directory (pathname prev)))))
+               (format stream "<tr class='subheading'><td colspan='11'>~A</td></tr>~%"
+                       (namestring (make-pathname :name nil :type nil :defaults source-file))))
+          do (coverage-stats-data-html stream source-file functions even report-name))
+        (format stream "</table>"))
+      index-file)))
+
+(defun colorize-function (function styles)
+  (let ((note (function-source-note function)))
+    ;; Change coverage flag to 'full if all subforms are covered.
+    (labels ((rec (note)
+               (when note
+                 (if (code-note-code-coverage note)
+                   (let ((subnotes (code-note-subform-notes note)))
+                     (map nil #'rec subnotes)
+                     (unless (find 'full subnotes :test #'neq
+                                   :key #'code-note-code-coverage)
+                       (setf (code-note-code-coverage note) 'full)))
+                   #+gz
+		   (let ((subnotes (code-note-subform-notes note)))
+		     (unless  (every #'(lambda (subnote)
+					 (null (code-note-code-coverage subnote)))
+				     subnotes)
+		       (warn "~s: Covered internal subnote in ~s" function note)
+		       #+no (map nil #'show-notes subnotes))
+		     (map nil #'rec subnotes))))))
+      (rec note))
+    ;; Now actually change text styles, from outside in.
+    (labels ((rec (note)
+               (let* ((style (case (code-note-code-coverage note)
+                              ((full) $totally-covered-style)
+                              ((nil) $not-executed-style)
+                              (t $partially-covered-style))))
+                 (when (source-note-p note)
+                   (fill styles style
+                         :start (source-note-start-pos note)
+                         :end (source-note-end-pos note)))
+                 (when (or (eq style $partially-covered-style)
+                           ;; If not a source note, descend in case have some subnotes
+                           ;; that can be showna
+                           (not (source-note-p note)))
+                   (map nil #'rec (code-note-subform-notes note))))))
+      (rec note))))
+
+(defun colorize-functions (functions styles)
+  (map nil #'(lambda (function) (colorize-function function styles)) functions))
+
+(defun report-file-coverage (file functions html-stream external-format)
+  "Print a code coverage report of FILE into the stream HTML-STREAM."
+  (format html-stream "<html><head>")
+  (write-coverage-styles html-stream)
+  (format html-stream "</head><body>")
+  (let* ((source (with-open-file (s file :external-format external-format)
+                   (let ((string (make-string (file-length s))))
+                     (read-sequence string s)
+                     string)))
+         (styles (make-array (length source)
+                             :initial-element 0
+                             :element-type '(unsigned-byte 2))))
+    (colorize-functions functions styles)
+    (print-coverage-report html-stream file styles source functions)
+    (format html-stream "</body></html>")))
+
+(defun print-coverage-report (html-stream file styles source functions)
+  (let ((*print-case* :downcase))
+    (format html-stream "<h3>Coverage report: ~a <br />~%</h3>~%" file)
+
+    (format html-stream "<table class='summary'>")
+    (coverage-stats-head-html html-stream)
+    (coverage-stats-data-html html-stream file functions)
+    (format html-stream "</table>")
+
+    (format html-stream "<div class='key'><b>Key</b><br />~%")
+    (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
+    (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
+    (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
+    (format html-stream "<p></p><div><code>~%")
+
+    (flet ((line (line)
+             (unless (eql line 0)
+               (format html-stream "</span>"))
+             (incf line)
+             (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code>&#160;" line)
+             line))
+      (loop with line = (line 0) with col = 0
+        for last-style = nil then style
+        for char across source
+        for style across styles
+        do (unless (eq style last-style)
+             (when last-style
+               (format html-stream "</span>"))
+             (format html-stream "<span class='state-~a'>" style))
+        do (case char
+             ((#\Newline)
+              (setq style nil)
+              (setq col 0)
+              (setq line (line line)))
+             ((#\Space)
+              (incf col)
+              (write-string "&#160;" html-stream))
+             ((#\Tab)
+              (dotimes (i (- 8 (mod col 8)))
+                (incf col)
+                (write-string "&#160;" html-stream)))
+             (t
+              (incf col)
+              (if (alphanumericp char)
+                (write-char char html-stream)
+                (format html-stream "&#~D;" (char-code char))))))
+      (format html-stream "</code></div>"))))
+
+
+(defun coverage-stats-head-html (html-stream)
+  (format html-stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expressions</td><td class='main-head' colspan='7'>Functions</td></tr>")
+  (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>"
+          (list "Source file"
+                "Total" "Covered" "% covered"
+                "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")))
+
+(defun coverage-stats-data-html (html-stream source-file functions &optional evenp report-name)
+  (format html-stream "<tr class='~:[odd~;even~]'>" evenp)
+  (if report-name
+    (format html-stream "<td class='text-cell'><a href='~a.html'>~a</a></td>" report-name source-file)
+    (format html-stream "<td class='text-cell'>~a</td>" source-file))
+  (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}"
+          (count-covered-expressions functions))
+  (destructuring-bind (total . counts) (count-covered-functions functions)
+    (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>"
+            total counts)))
+
+(defun count-covered-functions (functions)
+  (let ((fully 0) (partly 0) (never 0) (total 0))
+    (map nil #'(lambda (function)
+                 (let ((note (function-source-note function)))
+                   (when note
+                     (incf total)
+                     (case (code-note-code-coverage note)
+                       ((full) (incf fully))
+                       ((nil) (incf never))
+                       (t (incf partly))))))
+         functions)
+    (list total
+          fully (* 100.0 (/ fully total))
+          partly (* 100.0 (/ partly total))
+          never (* 100.0 (/ never total)))))
+
+(defun count-covered-expressions (functions)
+  (let ((covered 0) (total 0))
+    (map nil #'(lambda (function)
+                 (labels ((rec (note)
+                            (when note
+                              (incf total)
+                              (when (code-note-code-coverage note)
+                                (incf covered))
+                              (map nil #'rec (code-note-subform-notes note)))))
+                   (rec (function-source-note function))))
+         functions)
+    (list total covered  (* 100.0d0 (/ covered total)))))
+
+
+(defun write-coverage-styles (html-stream)
+  (format html-stream "<style type='text/css'>
+*.state-~a { background-color: #ffaaaa }
+*.state-~a { background-color: #aaffaa }
+*.state-~a { background-color: #44dd44 }
+div.key { margin: 20px; width: 88ex }
+div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px;
+             /* border-style: solid none none none; border-width: 1px;
+             border-color: #dddddd */ }
+
+*.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
+
+table.summary tr.head-row { background-color: #aaaaff }
+table.summary tr td.text-cell { text-align: left }
+table.summary tr td.main-head { text-align: center }
+table.summary tr td { text-align: right }
+table.summary tr.even { background-color: #eeeeff }
+table.summary tr.subheading { background-color: #aaaaff}
+table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
+</style>"
+          $not-executed-style
+          $partially-covered-style
+          $totally-covered-style
+          ))