Changeset 14058 for branches/qres

Timestamp:

Jul 27, 2010, 2:21:17 AM (10 years ago)

Author:

gz

Message:

support for code coverage of acode (r13891, r13929, r13942, r13964, r13965, r13966, r14044)

Location:

branches/qres/ccl

Files:

• . (modified) (1 prop)
• compiler/lambda-list.lisp (modified) (1 diff)
• compiler/nx-basic.lisp (modified) (5 diffs)
• compiler/nx0.lisp (modified) (2 diffs)
• level-1/l1-reader.lisp (modified) (1 diff)
• lib/pprint.lisp (modified) (6 diffs)
• library/cover.lisp (modified) (16 diffs)

branches/qres/ccl/compiler/lambda-list.lisp

@@ -35 +35 @@
 (defun function-source-note (fn)
   (getf (%lfun-info fn) '%function-source-note))
+
+(defun %function-acode-string (fn)
+  (getf (%lfun-info fn) '%function-acode-string))
 
 (defun uncompile-function (fn)

branches/qres/ccl/compiler/nx-basic.lisp

@@ -77 +77 @@
   ;; the note that was being compiled when this note was emitted.
   parent-note
+  ;; start/end position in the acode string for the toplevel lfun containing this code note.
+  acode-range
   #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused.
   form)
@@ -484 +486 @@
 
  
-(defun cons-var (name &optional (bits 0))
-  (%istruct 'var name bits nil nil nil nil nil nil))
+(defun nx-cons-var (name &optional (bits 0))
+  (%istruct 'var name bits nil nil nil nil 0 nil))
 
 
@@ -492 +494 @@
     (report-bad-arg env 'lexical-environment))
   (check-environment-args variable symbol-macro function macro)
-  (let* ((vars (mapcar #'cons-var variable))
+  (let* ((vars (mapcar #'nx-cons-var variable))
          (symbol-macros (mapcar #'(lambda (s)
                                     (let* ((sym (car s)))
@@ -499 +501 @@
                                                    (not (eq (variable-information sym env) :special)))
                                         (signal-program-error "~S can't by bound as a SYMBOL-MACRO" sym))
-                                      (let ((v (cons-var (car s)))) 
+                                      (let ((v (nx-cons-var (car s)))) 
                                         (setf (var-expansion v) (cons :symbol-macro (cadr s)))
                                         v)))
@@ -707 +709 @@
       (cdr (assq name (defenv.structrefs defenv))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  For code coverage, pretty-print acode to string and store position info in code notes.
+;;
+;;  decomp-acode can also be used separately for debugging.
+;;
+(defmacro dbg-assert (form)
+  #+debug-code-notes `(assert ,form))
+
+(defvar *acode-right-margin* 120)
+(defvar *nx-pprint-stream* nil)
+(defvar *nx-acode-inner-refs* :default)
+(defvar *nx-acode-refs-counter* 0)
+
+(defun nx-pprinting-p (stream)
+  (and *nx-pprint-stream*
+       (typep stream 'xp-stream)
+       (slot-value stream 'xp-structure)
+       (eq *nx-pprint-stream* (xp-base-stream (slot-value stream 'xp-structure)))))
+
+(defstruct acode-ref
+  object)
+
+(defstruct (acode-afunc-ref (:include acode-ref))
+  afunc
+  index)
+
+(defun nx-record-code-coverage-acode (afunc)
+  (assert *nx-current-code-note*)
+  (let* ((form->note (make-hash-table :test #'eq))
+         (*nx-acode-inner-refs* nil)
+         (*nx-acode-refs-counter* 0)
+         (form (decomp-acode (afunc-acode afunc)
+                             :prettify t
+                             :hook (lambda (acode form &aux (note (acode-note acode)))
+                                     ;; For expressions within without-compiling-code-coverage, there is a source
+                                     ;; note and not a code note, so need to check for code note explicitly.
+                                     (when (code-note-p note)
+                                       (dbg-assert (null (gethash form form->note)))
+                                       (dbg-assert (null (code-note-acode-range note)))
+                                       (setf (gethash form form->note) note)))))
+         (package *package*)
+         (string (with-standard-io-syntax
+                     (with-output-to-string (*nx-pprint-stream*)
+                       (let* ((*package* package)
+                              (*print-right-margin* *acode-right-margin*)
+                              (*print-case* :downcase)
+                              (*print-readably* nil))
+                         (pprint-recording-positions
+                          form *nx-pprint-stream*
+                          (lambda (form open-p pos)
+                            (let* ((note (gethash form form->note))
+                                   (range (and note (code-note-acode-range note))))
+                              (when note
+                                (cond (open-p
+                                       (dbg-assert (null range))
+                                       (setf (code-note-acode-range note)
+                                             (encode-file-range pos pos)))
+                                      (t
+                                       (dbg-assert (not (null range)))
+                                       (multiple-value-bind (start end)
+                                                            (decode-file-range range)
+                                         (declare (ignorable end))
+                                         (dbg-assert (eq start end))
+                                         (setf (code-note-acode-range note)
+                                               (encode-file-range start pos))))))))))))))
+    (iterate store ((afunc afunc))
+      (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
+      (loop for inner in (afunc-inner-functions afunc)
+        unless (getf (afunc-lfun-info inner) '%function-acode-string)
+        do (store inner)))
+    afunc))
+
+(defmethod print-object ((ref acode-afunc-ref) stream)
+  (if (nx-pprinting-p stream)
+    (let ((index (acode-afunc-ref-index ref)))
+      (when index ;; referenced multiple times.
+        (if (eql index 0)  ;; never referenced before?
+          (format stream "#~d=" 
+                  (setf (acode-afunc-ref-index ref) (incf *nx-acode-refs-counter*)))
+          ;; If not first reference, just point back.
+          (return-from print-object (format stream "#~d#" index))))
+      (write-1 (acode-afunc-ref-object ref) stream))
+    (call-next-method)))
+
+(defmethod print-object ((ref acode-ref) stream)
+  (if (nx-pprinting-p stream)
+    (write-1 (acode-ref-object ref) stream)
+    (call-next-method)))
+
+(defun decomp-ref (obj)
+  (if (and (listp *nx-acode-inner-refs*) ;; code coverage case
+           (not (acode-p obj)))
+    (make-acode-ref :object obj)
+    obj))
+
+(defvar *decomp-prettify* nil "If true, loses info but results in more recognizable lisp")
+
+(defvar *decomp-hook* nil)
+
+(defun decomp-acode (acode &key (hook *decomp-hook*) (prettify *decomp-prettify*))
+  (let ((*decomp-hook* hook)
+        (*decomp-prettify* prettify))
+    (decomp-form acode)))
+
+(defun decomp-form (acode)
+  (cond ((eq acode *nx-t*) t)
+        ((eq acode *nx-nil*) nil)
+        (t (let* ((op (car acode))
+                  (num (length *next-nx-operators*))
+                  (name (when (and (fixnump op)
+                                   (<= 0 op)
+                                   (setq op (logand op operator-id-mask))
+                                   (< op num))
+                          (car (nth (- num op 1) *next-nx-operators*))))
+                  (new (decomp-using-name (or name op) (cdr acode))))
+             (when *decomp-hook*
+               (funcall *decomp-hook* acode new))
+             new))))
+
+
+(defun decomp-afunc (afunc)
+  (setq afunc (require-type afunc 'afunc))
+  (dbg-assert (afunc-acode afunc))
+  (if (listp *nx-acode-inner-refs*)    ;; code coverage case
+      (let ((ref (find afunc *nx-acode-inner-refs* :key #'acode-afunc-ref-afunc)))
+        (if ref ;; seen before, mark that multiply referenced.
+            (setf (acode-afunc-ref-index ref) 0)
+            (push (setq ref (make-acode-afunc-ref :afunc afunc
+                                                  :object (decomp-form (afunc-acode afunc))))
+                  *nx-acode-inner-refs*))
+        ref)
+      afunc))
+
+(defun decomp-var (var)
+  (decomp-ref (var-name (require-type var 'var))))
+
+(defun decomp-formlist (formlist)
+  (mapcar #'decomp-form formlist))
+
+(defun decomp-arglist (arglist)
+  (destructuring-bind (stack-forms register-forms) arglist
+    (nconc (decomp-formlist stack-forms)
+           (nreverse (decomp-formlist register-forms)))))
+
+(defun decomp-lambda-list (req opt rest keys auxen &optional whole)
+  (flet ((decomp-arg (var)
+           (if (acode-p var)
+             (destructuring-bind (op whole req opt rest keys auxen) var
+               (assert (eq op (%nx1-operator lambda-list))) ;; fake
+               (decomp-lambda-list req opt rest keys auxen whole))
+             (decomp-var var))))
+    (let ((whole (and whole (list '&whole (decomp-arg whole))))
+          (reqs (mapcar #'decomp-arg req))
+          (opts (when opt (cons '&optional (apply #'mapcar
+                                                  (lambda (var init supp)
+                                                    (if (and (not supp) (eq init *nx-nil*))
+                                                      (decomp-arg var)
+                                                      (list* (decomp-arg var)
+                                                             (decomp-form init)
+                                                             (and supp (list (decomp-arg supp))))))
+                                                  opt))))
+          (rest (when rest (list '&rest (decomp-arg rest))))
+          (keys (when keys
+                  (destructuring-bind (aok vars supps inits keyvect) keys
+                    (nconc
+                     (when vars
+                       (cons '&key (map 'list (lambda (var supp init key)
+                                                (let* ((sym (decomp-arg var))
+                                                       (arg (if (and (symbolp sym) (eq (make-keyword sym) key))
+                                                              sym
+                                                              (list key sym))))
+                                                  (if (and (not supp) (eq init *nx-nil*) (eq arg sym))
+                                                    sym
+                                                    (list* arg
+                                                           (decomp-form init)
+                                                           (and supp (list (decomp-arg supp)))))))
+                                        vars supps inits keyvect)))
+                     (when aok (list '&allow-other-keys))))))
+          (auxen (when (car auxen)
+                   (cons '&aux (apply #'mapcar
+                                      (lambda (var init)
+                                        (if (eq init *nx-nil*)
+                                          (decomp-arg var)
+                                          (list (decomp-arg var) (decomp-form init))))
+                                      auxen)))))
+      (nconc whole reqs opts rest keys auxen))))
+
+(defmacro defdecomp (names arglist &body body)
+  (let ((op-var (car arglist))
+        (args-vars (cdr arglist))
+        (op-decls nil)
+        (args-var (gensym)))
+    (multiple-value-bind (body decls) (parse-body body nil)
+    ;; Kludge but good enuff for here
+      (setq decls (loop for decl in decls
+                    collect (cons (car decl)
+                                  (loop for exp in (cdr decl)
+                                    do (when (and (consp exp) (member op-var (cdr exp)))
+                                         (push (list (car exp) op-var) op-decls))
+                                    collect (cons (car exp) (remove op-var (cdr exp)))))))
+    `(progn
+       ,@(loop for name in (if (atom names) (list names) names)
+           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var)
+                      (declare ,@op-decls)
+                      (destructuring-bind ,args-vars ,args-var
+                        ,@decls
+                        ,@body)))))))
+
+;; Default method
+(defmethod decomp-using-name (op forms)
+  `(,op ,@(decomp-formlist forms)))
+
+;; not real op, kludge generated below for lambda-bind
+(defdecomp keyref (op index)
+  `(,op ,index))
+
+(defdecomp immediate (op imm)
+  (when *decomp-prettify*
+    (setq op 'quote))
+  `(,op ,imm))
+
+(defdecomp fixnum (op raw-fixnum)
+  (declare (ignore op))
+  (decomp-ref raw-fixnum))
+
+(defdecomp %function (op symbol)
+  (when *decomp-prettify*
+    (setq op 'function))
+  `(,op ,symbol))
+
+(defdecomp simple-function (op afunc)
+  (when *decomp-prettify*
+    (setq op 'function))
+  `(,op ,(decomp-afunc afunc)))
+
+(defdecomp closed-function (op afunc)
+  (when *decomp-prettify*
+    (setq op 'function))
+  `(,op ,(decomp-afunc afunc)))
+
+(defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
+  `(,op ,@(decomp-formlist form-list)))
+
+(defdecomp multiple-value-call (op fn form-list)
+  `(,op ,(decomp-form fn) ,@(decomp-formlist form-list)))
+
+(defdecomp vector (op formlist)
+  `(,op ,@(decomp-formlist formlist)))
+
+(defdecomp (%gvector list* %err-disp) (op arglist)
+  `(,op ,@(decomp-arglist arglist)))
+
+(defdecomp (i386-syscall syscall eabi-syscall poweropen-syscall
+            i386-ff-call ff-call eabi-ff-call poweropen-ff-call)
+           (op target argspecs argvals resultspec &rest rest)
+  `(,op
+    ,(decomp-form target)
+    ,@(mapcan (lambda (spec val) (list spec (decomp-form val))) argspecs argvals)
+    ,resultspec
+    ,@rest))
+
+(defdecomp (consp characterp istruct-typep %ptr-eql int>0-p %izerop endp eq %ilogbitp %base-char-p not neq) (op cc &rest forms)
+  (if (eq (acode-immediate-operand cc) :eq)
+    `(,op ,@(decomp-formlist forms))
+    `(,op ,(decomp-form cc) ,@(decomp-formlist forms))))
+
+(defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
+  `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p))))
+
+(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
+  `(,op ,(decomp-form form1) ,(decomp-form form2) ,overflow-p))
+
+(defdecomp (immediate-get-xxx %immediate-set-xxx) (op bits &rest forms)
+  `(,op ,bits ,@(decomp-formlist forms)))
+
+(defdecomp call (op fn arglist &optional spread-p)
+  (setq op (if spread-p 'apply 'funcall))
+  `(,op ,(decomp-form fn) ,@(decomp-arglist arglist)))
+
+(defdecomp lexical-function-call (op afunc arglist &optional spread-p)
+  (setq op (if *decomp-prettify*
+             (if spread-p 'apply 'funcall)
+             (if spread-p 'lexical-apply 'lexical-funcall)))
+  `(,op ,(decomp-afunc afunc) ,@(decomp-arglist arglist)))
+
+(defdecomp self-call (op arglist &optional spread-p)
+  (declare (Ignore op))
+  `(,(if spread-p 'self-apply 'self-funcall) ,@(decomp-arglist arglist)))
+
+(defdecomp (free-reference special-ref bound-special-ref global-ref) (op symbol)
+  (if *decomp-prettify*
+    (decomp-ref symbol)
+    `(,op ,symbol)))
+
+(defdecomp (setq-special setq-free global-setq) (op symbol form)
+  (when *decomp-prettify*
+    (setq op 'setq))
+  `(,op ,symbol ,(decomp-form form)))
+
+(defdecomp inherited-arg (op var)
+  `(,op ,(decomp-var var)))
+
+(defdecomp lexical-reference (op var)
+  (if *decomp-prettify*
+    (decomp-var var)
+    `(,op ,(decomp-var var))))
+
+(defdecomp setq-lexical (op var form)
+  (when *decomp-prettify*
+    (setq op 'setq))
+  `(,op ,(decomp-var var) ,(decomp-form form)))
+
+(defdecomp (let let* with-downward-closures) (op vars vals body p2decls)
+  (declare (ignore p2decls))
+  `(,op ,(mapcar (lambda (var val) (list (decomp-var var) (decomp-form val))) vars vals)
+    ,(decomp-form body)))
+
+(defdecomp %decls-body (op form p2decls)
+  (declare (ignore p2decls))
+  `(,op ,(decomp-form form)))
+
+(defdecomp multiple-value-bind (op vars form body p2decls)
+  (declare (ignore p2decls))
+  `(,op ,(mapcar #'decomp-var vars) ,(decomp-form form) ,(decomp-form body)))
+
+
+(defdecomp lambda-list (op req opt rest keys auxen body p2decls &optional code-note)
+  (declare (ignore p2decls code-note))
+  (when *decomp-prettify*
+    (setq op 'lambda))
+  `(,op ,(decomp-lambda-list req opt rest keys auxen) ,(decomp-form body)))
+
+(defdecomp debind (op ll form req opt rest keys auxen whole body p2decls cdr-p)
+  (declare (ignore ll p2decls cdr-p))
+  `(,op ,(decomp-lambda-list req opt rest keys auxen whole) ,(decomp-form form) ,(decomp-form body)))
+
+(defdecomp lambda-bind (op vals req rest keys-p auxen body p2decls)
+  (declare (ignore keys-p p2decls))
+  (when (find-if #'fixnump (cadr auxen))
+    (destructuring-bind (vars vals) auxen
+      (setq auxen (list vars
+                        (mapcar (lambda (x) (if (fixnump x) `(keyref ,x) x)) vals)))))
+  (let ((lambda-list (decomp-lambda-list req nil rest nil  auxen)))
+    `(,op ,lambda-list ,(decomp-formlist vals) ,(decomp-form body))))
+
+(defdecomp (flet labels) (op vars afuncs body p2decls)
+  (declare (ignore p2decls))
+  `(,op ,(mapcar (lambda (var afunc)
+                            (list (decomp-var var) (decomp-afunc afunc)))
+                          vars afuncs)
+    ,(decomp-form body)))
+
+(defdecomp local-go (op tag)
+  (when *decomp-prettify*
+    (setq op 'go))
+  `(,op ,(car tag)))
+
+(defdecomp tag-label (op &rest tag)
+  (if *decomp-prettify*
+    (decomp-ref (car tag))
+    `(,op ,(car tag))))
+
+(defdecomp local-tagbody (op tags forms)
+  (declare (ignore tags))
+  (when *decomp-prettify*
+    (setq op 'tagbody))
+  `(,op ,@(decomp-formlist forms)))
+
+(defdecomp local-block (op block body)
+  (when *decomp-prettify*
+    (setq op 'block))
+  `(,op ,(car block) ,(decomp-form body)))
+
+(defdecomp local-return-from (op block form)
+  (when *decomp-prettify*
+    (setq op 'return-from))
+  `(,op ,(car block) ,(decomp-form form)))
+
 ; end

branches/qres/ccl/compiler/nx0.lisp

@@ -61 +61 @@
 
 (defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
-
-
-; The compiler can (generally) use temporary vectors for VARs.
-(defun nx-cons-var (name &optional (bits 0))
-  (%istruct 'var name bits nil nil nil nil 0 nil))
-
-
-
 
 (defvar *nx-lambdalist* (make-symbol "lambdalist"))
@@ -1445 +1437 @@
     (setf (afunc-vcells p) *nx1-vcells*)
     (setf (afunc-fcells p) *nx1-fcells*)
+    (when *nx-current-code-note*
+      (when (null q) ;; toplevel functions only
+        (nx-record-code-coverage-acode p)))
     (let* ((warnings (merge-compiler-warnings *nx-warnings*))
            (name *nx-cur-func-name*))        

branches/qres/ccl/level-1/l1-reader.lisp

@@ -3087 +3087 @@
       (cons start-pos end-pos))))
 
+(defun decode-file-range (range)
+  (when range
+    (if (consp range)
+      (values (car range) (cdr range))
+      (let ((start-pos (ash range -14)))
+        (values start-pos (+ start-pos (logand range #x3FFF)))))))
+
 (defun source-note-text (source-note &optional start end)
   (when source-note

branches/qres/ccl/lib/pprint.lisp

@@ -175 +175 @@
   (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
   (structures (make-hash-table :test #'eq) :type (or null hash-table))
-  (others nil :type list))
+  (others nil :type list)
+  (commit-hook nil))
 
 ;The list and the hash-tables contain entries of the
@@ -199 +200 @@
       :conses-with-cars new-conses-with-cars
       :structures new-structures
-      :others (copy-list (others table)))))
+      :others (copy-list (others table))
+      :commit-hook (commit-hook table))))
 
 
@@ -939 +941 @@
                           (maybe-too-large xp qleft queue linel)))
                (T T)) ;(:linear :unconditional :mandatory) 
-         (output-line xp qleft)
-         (setup-for-next-line xp qleft))))
+         (output-line-and-setup-for-next xp qleft))))
     (setf (xp-qleft xp) (setq qleft (qnext qleft))))
   (when flush-out? (flush xp)))))
@@ -947 +948 @@
 
 (defun flush (xp)
-  (let ((ostream (xp-out-stream xp)))
+  (let ((ostream (xp-out-stream xp))
+        (len (xp-buffer-ptr xp)))
+    (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*))
+      (funcall (commit-hook *print-pprint-dispatch*) xp len 0))
     (when ostream      
-      (write-string (xp-buffer xp) ostream :start 0 :end (xp-buffer-ptr xp)))
-    (incf (xp-buffer-offset xp) (xp-buffer-ptr xp))
-    (incf (xp-charpos xp) (xp-buffer-ptr xp))
+      (write-string (xp-buffer xp) ostream :start 0 :end len))
+    (incf (xp-buffer-offset xp) len)
+    (incf (xp-charpos xp) len)
     (setf (xp-buffer-ptr xp) 0)))
 
@@ -968 +972 @@
 ;This prints out a line of stuff.
 
-(defun output-line (xp Qentry)
-  (flet ((find-not-char-reverse (buffer out-point)
-           (declare (type simple-base-string buffer) (type fixnum out-point))
-           (do ((i (%i- out-point 1) (%i- i 1)))
-               ((%i< i 0) nil)
-             (when (or (neq (schar buffer i) #\Space)
-                       ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be 
-                       ;; quoted; don't bother checking for that, no big harm leaving the space even if
-                       ;; not totally necessary).
-                       (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\)))
-               (return i)))))
-    (let* ((queue (xp-queue xp))
-           (out-point (BP<-TP xp (xpq-pos queue Qentry)))
-           (last-non-blank (find-not-char-reverse (xp-buffer xp) out-point))
-           (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point)
-                      (last-non-blank (%i+ 1 last-non-blank))
-                      (T 0)))
-           (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
-      (when line-limit-exit
-        (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
-        (write-string+++ " .." xp 0 3)
-        (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
-        (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
-        (setf (xp-qleft xp) (qnext (xp-qright xp)))
-        ;(setq *abbreviation-happened* '*print-lines*)
-        (throw 'line-limit-abbreviation-exit T))
-      (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
-      (let ((bstream (xp-out-stream xp)))
-        (when bstream
-          (write-string (xp-buffer xp) bstream :start 0 :end end)
-          (stream-write-char bstream #\newline))))))
-
-(defun setup-for-next-line (xp Qentry)
+(defun output-line-and-setup-for-next (xp Qentry)
   (let* ((queue (xp-queue xp))
          (out-point (BP<-TP xp (xpq-pos queue Qentry)))
-         (prefix-end
-          (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh))
-                 (non-blank-prefix-ptr xp))
-                (T (prefix-ptr xp))))
-         (change (- prefix-end out-point)))
-    (declare (fixnum out-point prefix-end change))
+         (unconditional-p (memq (xpq-kind queue Qentry) '(:fresh :unconditional)))
+         (end (if unconditional-p
+                out-point
+                (let ((buffer (xp-buffer xp)))
+                  (declare (type simple-base-string buffer))
+                  (do ((i (%i- out-point 1) (%i- i 1)))
+                      ((%i< i 0) 0)
+                    (when (or (neq (schar buffer i) #\Space)
+                              ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be 
+                              ;; quoted; don't bother checking for that, no big harm leaving the space even if
+                              ;; not totally necessary).
+                              (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\)))
+                      (return (%i+ i 1)))))))
+         (prefix-end
+          (if unconditional-p (non-blank-prefix-ptr xp) (prefix-ptr xp)))
+         (old-ptr (xp-buffer-ptr xp))
+         (new-ptr (%i+ old-ptr (%i- prefix-end out-point)))
+         (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
+    (when line-limit-exit
+      (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
+      (write-string+++ " .." xp 0 3)
+      (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
+      (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
+      (setf (xp-qleft xp) (qnext (xp-qright xp)))
+      ;(setq *abbreviation-happened* '*print-lines*)
+      (throw 'line-limit-abbreviation-exit T))
+    (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
+    (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*))
+      (funcall (commit-hook *print-pprint-dispatch*) xp out-point prefix-end))
+    (let ((bstream (xp-out-stream xp)))
+      (when bstream
+        (write-string (xp-buffer xp) bstream :start 0 :end end)
+        (stream-write-char bstream #\newline)))
     (setf (xp-charpos xp) 0)
-    (when (plusp change)                  ;almost never happens
-      (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change)
-                     #.buffer-min-size #.buffer-entry-size))
+    (when (%i> new-ptr old-ptr)                  ;almost never happens
+      (xp-check-size (xp-buffer xp) new-ptr #.buffer-min-size #.buffer-entry-size))
+    (setf (xp-buffer-ptr xp) new-ptr)
+    (decf (xp-buffer-offset xp) (- prefix-end out-point))
     (let ((buffer (xp-buffer xp)))
-      (replace buffer buffer :start1 prefix-end
-               :start2 out-point :end2 (xp-buffer-ptr xp))
+      (replace buffer buffer :start1 prefix-end :start2 out-point :end2 old-ptr)
       (replace buffer (xp-prefix xp) :end2 prefix-end)
-      (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change))
-      (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change))
-      (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh)))
+      (unless unconditional-p
         (setf (section-start-line xp) (xp-line-no xp))))))
+
+
 
 (defun set-indentation-prefix (xp new-position)
@@ -1310 +1309 @@
 (defmethod stream-finish-output ((xp xp-structure))
   (attempt-to-output xp t t))
+
+(defun pprint-recording-positions (form stream recorder)
+  ;; The hair here comes from the fact that the pretty printer backtracks to insert newlines.
+  (let* ((old-table *print-pprint-dispatch*)
+         (rec-pending nil)
+         (record (require-type recorder 'function)))
+    (flet ((rec-pprint (xp object)
+             #+gz (assert (or (null rec-pending)
+                              (<= (caar rec-pending) (xp-buffer-ptr xp))))
+             (let ((real-printer (get-printer object old-table)))
+               (when real-printer
+                 (push (list* (xp-buffer-ptr xp) t object) rec-pending)
+                 (funcall real-printer xp object)
+                 (push (list* (xp-buffer-ptr xp) nil object) rec-pending))))
+           (rec-commit (xp commited inserted)
+             (loop with change = (- inserted commited)
+               as last = nil then pending
+               as pending = rec-pending then (cdr pending) while pending
+               do (when (<= (caar pending) commited) ;; commit the rest.
+                    (if last
+                      (setf (cdr last) nil)
+                      (setf rec-pending nil))
+                    (loop with start = (stream-position (xp-out-stream xp))
+                      for (offset open-p . object) in (nreverse pending)
+                      do (funcall record object open-p (+ start offset)))
+                    (return nil))
+               do (incf (caar pending) change))))
+      (let* ((*print-pretty* t)
+             (*print-circle* nil)
+             (*print-length* nil)
+             (*print-level* nil)
+             (*print-lines* nil)
+             (*print-miser-width* nil)
+             (*read-suppress* nil)
+             (*print-pprint-dispatch* (make-pprint-dispatch-table :commit-hook #'rec-commit)))
+        (set-pprint-dispatch 'cons #'rec-pprint)
+        (write-1 form stream)
+        #+gz (assert (null rec-pending))))
+    form))
+
 
 

branches/qres/ccl/library/cover.lisp

@@ -47 +47 @@
           without-compiling-code-coverage))
 
-(defconstant $not-executed-style 2)
-(defconstant $totally-covered-style 5)
-(defconstant $partially-covered-style 6)
+(defconstant $no-style 0)
+(defconstant $not-executed-style 1)
+(defconstant $totally-covered-style 2)
+(defconstant $partially-covered-style 3)
 
 (defparameter *file-coverage* ())
@@ -55 +56 @@
 (defparameter *emitted-code-notes* (make-hash-table :test #'eq))
 (defparameter *entry-code-notes* (make-hash-table :test #'eq))
-
+(defparameter *code-note-acode-strings* (make-hash-table :test #'eq))
+
+(defparameter *coverage-acode-queue* nil)
 
 (defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
@@ -83 +86 @@
 (defun entry-code-note-p (note)
   (gethash note *entry-code-notes*))
+
+(defun code-note-acode-string (note)
+  (gethash note *code-note-acode-strings*))
 
 (defun map-function-coverage (lfun fn &optional refs)
@@ -94 +100 @@
               do (map-function-coverage imm fn refs))))
 
-(defun get-function-coverage (fn refs)
+(defun get-function-coverage (fn refs acode)
   (let ((entry (function-entry-code-note fn))
-        (refs (cons fn refs)))
+        (refs (cons fn refs))
+        (acode (or (%function-acode-string fn) acode)))
     (declare (dynamic-extent refs))
     (when entry
       (assert (eq fn (gethash entry *entry-code-notes* fn)))
-      (setf (gethash entry *entry-code-notes*) fn))
+      (setf (gethash entry *entry-code-notes*) fn)
+      (when acode
+        (setf (gethash entry *code-note-acode-strings*) acode)))
     (nconc
      (and entry (list fn))
      (lfunloop for imm in fn
        when (code-note-p imm)
-       do (setf (gethash imm *emitted-code-notes*) t)
+       do (progn
+            (setf (gethash imm *emitted-code-notes*) t)
+            (when acode
+              (setf (gethash imm *code-note-acode-strings*) acode)))
        when (and (functionp imm)
                  (not (memq imm refs)))
-       nconc (get-function-coverage imm refs)))))
+       nconc (get-function-coverage imm refs acode)))))
 
 (defun code-covered-info.file (data) (and (consp data) (car data)))
@@ -128 +140 @@
   (clrhash *emitted-code-notes*)
   (clrhash *entry-code-notes*)
+  (clrhash *code-note-acode-strings*)
   (loop for data in *code-covered-functions*
         do (let* ((file (code-covered-info.file data))
@@ -138 +151 @@
                             (delete-duplicates
                              (loop for fn across toplevel-functions
-                                   nconc (get-function-coverage fn nil)))
+                                   nconc (get-function-coverage fn nil nil)))
                             toplevel-functions)
                      *file-coverage*))))
@@ -146 +159 @@
                  while parent
                  do (pushnew n (gethash parent *coverage-subnotes*))
-                 until (emitted-code-note-p parent))))
+                 until (emitted-code-note-p parent)))
+  (let ((hash (make-hash-table :test #'eq)))
+    ;; distribute entry acode to the toplevel source note it belongs to.
+    (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn)
+      as acode = (code-note-acode-string entry)
+      as sn = (entry-note-unambiguous-source entry)
+      as toplevel-sn = (function-source-form-note fn)
+      do (when sn
+           (assert toplevel-sn)
+           (let* ((pos (source-note-end-pos sn))
+                  (cell (assq acode (gethash toplevel-sn hash))))
+             (if cell
+               (setf (cdr cell) (max (cdr cell) pos))
+               (push (cons acode pos) (gethash toplevel-sn hash))))))
+    (setf *coverage-acode-queue*
+          (sort (loop for sn being the hash-key of hash using (hash-value alist)
+                  collect (cons (source-note-end-pos sn)
+                                (mapcar #'car (sort alist #'< :key #'cdr))))
+                #'< :key #'car))))
 
 #+debug
@@ -159 +190 @@
              (when (entry-code-note-p note)
                (format t " (Entry to ~s)" (entry-code-note-p note)))
+             (when (code-note-acode-range note)
+               (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note))
+                 (format t " [acode ~a:~a]" s e)))
              (format t "~%")
              (when (code-note-p note)
@@ -573 +607 @@
 
 
+(defun style-for-coverage (coverage)
+  (case coverage
+    ((full) $totally-covered-style)
+    ((nil) $not-executed-style)
+    (t $partially-covered-style)))
+  
 (defun fill-with-text-style (coverage location-note styles)
-  (let ((style (case coverage
-                 ((full) $totally-covered-style)
-                 ((nil) $not-executed-style)
-                 (t $partially-covered-style))))
-    (fill styles style
-          :start (source-note-start-pos location-note)
-          :end (source-note-end-pos location-note))))
+  (fill styles (style-for-coverage coverage)
+        :start (source-note-start-pos location-note)
+        :end (source-note-end-pos location-note)))
 
 (defun update-text-styles (note styles)
@@ -642 +678 @@
              (return sn))))
 
-  
-(defun colorize-function (fn styles &optional refs)
+(defun colorize-acode (fn acode-styles)
+  (let* ((acode (%function-acode-string fn))
+         (note (function-entry-code-note fn))
+         (range (and note (code-note-acode-range note))))
+    (when (and acode range)
+      (let ((styles (or (gethash acode acode-styles)
+                        (setf (gethash acode acode-styles)
+                              (make-array (length acode)
+                                          :initial-element $no-style
+                                          :element-type '(unsigned-byte 2))))))
+        (iterate update ((note note))
+          (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note))
+            (when (and start
+                       (setq start (position-if-not #'whitespacep acode :start start :end end)))
+              (fill styles (style-for-coverage (code-note-code-coverage note))
+                    :start start
+                    :end end)))
+          (loop for sub in (coverage-subnotes note)
+            unless (entry-code-note-p sub)
+            do (update sub)))))))
+
+(defun colorize-function (fn styles acode-styles &optional refs)
   (let* ((note (function-entry-code-note fn))
          (source (function-source-form-note fn))
@@ -650 +706 @@
     ;; Colorize the body of the function
     (when note
-      (colorize-source-note note styles))
+      (colorize-source-note note styles)
+      (colorize-acode fn acode-styles))
     ;; And now any subfunction references
     (lfunloop for imm in fn
@@ -664 +721 @@
                                       (warn "Ignoring ref to ~s from ~s" imm fn)
                                       nil)))
-              do (colorize-function imm styles refs))))
+              do (colorize-function imm styles acode-styles refs))))
 
 (defun report-file-coverage (index-file coverage html-stream external-format)
@@ -676 +733 @@
                      string)))
          (styles (make-array (length source)
-                             :initial-element 0
-                             :element-type '(unsigned-byte 2))))
-    (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage))
-    (print-file-coverage-report index-file html-stream coverage styles source)
+                             :initial-element $no-style
+                             :element-type '(unsigned-byte 2)))
+         (acode-styles (make-hash-table :test #'eq)))
+    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage))
+    (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
     (format html-stream "</body></html>")))
 
-(defun print-file-coverage-report (index-file html-stream coverage styles source)
+(defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source)
   (let ((*print-case* :downcase))
     (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
@@ -694 +752 @@
 
     (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))
+    (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
+    (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
+    (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
+    (format html-stream "</div><p></p>~%")
+
+    ;; Output source intertwined with acode
+    (iterate output ((start 0) (line 0))
+      (format html-stream "<div class='source'><code>")
+      (let ((next (car *coverage-acode-queue*)))
+        (multiple-value-bind (end last-line)
+                             (output-styled html-stream source styles
+                                            :start start
+                                            :line line
+                                            :limit (car next))
+          (format html-stream "</code></div>~%")
+          (when (and next end (<= (car next) end))
+            (destructuring-bind (pos . strings) next
+              (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~
+                                   <div class='acode' id='a~:*~d'><code>" pos)
+              (loop for acode in strings as styles = (gethash acode acode-styles)
+                do (assert styles)
+                do (output-styled html-stream acode styles)
+                do (fresh-line html-stream))
+              (format html-stream "</code></div><hr/>~%"))
+            (pop *coverage-acode-queue*)
+            (output (1+ end) last-line)))))))
+
+(defun output-styled (html-stream source styles &key (start 0) line limit)
+  (let ((last-style $no-style)
+        (col 0)
+        (line line))
+    (labels ((outch (char)
+               (if (eql char #\Tab)
+                 (dotimes (i (- 8 (mod col 8)))
+                   (incf col)
+                   (write-string " " html-stream))
+                 (progn
+                   (incf col)
+                   (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe
+                     (write-char char html-stream)
+                     (format html-stream "&#~D;" (char-code char))))))
+             (start-line ()
+               (when line
+                 (incf line)
+                 (format html-stream "<span class='line'>~A</span>" line))
+               (write-char #\space html-stream)
+               (setq col 0))
+             (set-style (new)
+               (unless (eq last-style new)
+                 (unless (eq last-style $no-style) (format html-stream "</span>"))
+                 (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new))
+                 (setq last-style new)))
+             (end-line ()
+               (set-style $no-style)
+               (format html-stream "~%")))
+      (declare (inline outch start-line end-line))
+      (unless limit (setq limit (length source)))
+      (start-line)
+      (loop
+        for pos from start below (length source)
+        as char = (aref source pos) as style = (aref styles pos)
+        do (set-style 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)))
+              (end-line)
+              (when (<= limit pos)
+                (return (values pos line)))
+              (start-line))
              (t
-              (incf col)
-              (if (alphanumericp char)
-                (write-char char html-stream)
-                (format html-stream "&#~D;" (char-code char))))))
-      (format html-stream "</code></div>"))))
+              (outch char)))
+        finally (end-line)))))
 
 
@@ -875 +967 @@
 (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;
+*.st~a { background-color: #ffaaaa }
+*.st~a { background-color: #aaffaa }
+*.st~a { background-color: #44dd44 }
+*.key { margin: 20px; width: 88ex }
+*.source { width: 120ex; 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; }
+             border-color: #dddddd */
+             white-space: pre; }
+
+*.acode { border-left: 1px dashed #c0c0c0;
+         margin-top: 1ex;
+         margin-left: 6ex;
+         margin-bottom: 2ex;
+         white-space: pre;
+         display: none; }
+
+*.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
+
+*.toggle { font-size: small; }
 
 table.summary tr.head-row { background-color: #aaaaff }
@@ -892 +994 @@
 table.summary tr.subheading { background-color: #aaaaff}
 table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
-</style>"
+
+</style>
+
+<script type='text/javascript'>
+function swap (id) {
+  var acode = document.getElementById('a' + id);
+  var prompt = document.getElementById('p' + id);
+  if (acode.style.display == 'block') {
+      acode.style.display = 'none';
+      prompt.innerHTML = 'Show expansion';
+  } else {
+    acode.style.display = 'block';
+    prompt.innerHTML = 'Hide expansion';
+  }
+}
+</script>
+"
           $not-executed-style
           $partially-covered-style
           $totally-covered-style
           ))
+