Index: /branches/working-0711/ccl/compiler/X86/x862.lisp
===================================================================
--- /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 9733)
+++ /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 9734)
@@ -3365,11 +3365,11 @@
(defun x862-acode-operator-supports-push (form)
- (setq form (acode-unwrapped-form-value form))
- (when (acode-p form)
- (if (or (eq form *nx-t*)
- (eq form *nx-nil*)
- (let* ((operator (acode-operator form)))
- (member operator *x862-operator-supports-push*)))
- form)))
+ (let ((value (acode-unwrapped-form-value form)))
+ (when (acode-p value)
+ (if (or (eq value *nx-t*)
+ (eq value *nx-nil*)
+ (let* ((operator (acode-operator value)))
+ (member operator *x862-operator-supports-push*)))
+ (acode-unwrapped-form form)))))
(defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator)
Index: /branches/working-0711/ccl/level-1/l1-init.lisp
===================================================================
--- /branches/working-0711/ccl/level-1/l1-init.lisp (revision 9733)
+++ /branches/working-0711/ccl/level-1/l1-init.lisp (revision 9734)
@@ -260,5 +260,5 @@
(defvar *save-definitions* nil)
(defvar *save-local-symbols* t)
-(defvar *save-source-locations* nil
+(defvar *save-source-locations* #+gz t #-gz nil
"Controls whether complete source locations is stored.
Index: /branches/working-0711/ccl/level-1/l1-reader.lisp
===================================================================
--- /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 9733)
+++ /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 9734)
@@ -2602,5 +2602,7 @@
(lambda (stream ignore)
(declare (ignore ignore))
- `(quote ,(read stream t nil t)))))
+ (multiple-value-bind (form source-note)
+ (read-internal stream t nil t)
+ (values `(quote ,form) (and source-note (list source-note)))))))
(defparameter *alternate-line-terminator*
@@ -2665,19 +2667,23 @@
(declare (ignore subchar))
(if (or (null numarg) *read-suppress*)
- (let* ((lst (read-list stream t))
- (len (length lst))
+ (multiple-value-bind (lst notes) (read-list stream t)
+ (let* ((len (length lst))
(vec (make-array len)))
(declare (list lst) (fixnum len) (simple-vector vec))
- (dotimes (i len vec)
- (setf (svref vec i) (pop lst))))
+ (dotimes (i len)
+ (setf (svref vec i) (pop lst)))
+ (values vec notes)))
(locally
(declare (fixnum numarg))
(do* ((vec (make-array numarg))
+ (notes ())
(lastform)
(i 0 (1+ i)))
- ((multiple-value-bind (form form-p)
+ ((multiple-value-bind (form form-p source-info)
(%read-list-expression stream nil)
(if form-p
- (setq lastform form)
+ (progn
+ (setq lastform form)
+ (when source-info (push source-info notes)))
(unless (= i numarg)
(if (= i 0)
@@ -2688,5 +2694,5 @@
(setf (svref vec j) lastform)))))
(not form-p))
- vec)
+ (values vec notes))
(declare (fixnum i))
(setf (svref vec i) lastform)))))))
@@ -2725,8 +2731,8 @@
#\#
#\C
- #'(lambda (stream char arg &aux form)
+ #'(lambda (stream char arg)
(require-no-numarg char arg )
- (setq form (read stream t nil t))
- (unless *read-suppress* (apply #'complex form))))
+ (multiple-value-bind (form note) (read-internal stream t nil t)
+ (values (unless *read-suppress* (apply #'complex form)) (and note (list note))))))
(set-dispatch-macro-character
@@ -2812,5 +2818,6 @@
(lambda (stream subchar numarg)
(require-no-numarg subchar numarg)
- `(function ,(read stream t nil t)))))
+ (multiple-value-bind (form note) (read-internal stream t nil t)
+ (values `(function ,form) (and note (list note)))))))
(set-dispatch-macro-character
@@ -2917,5 +2924,7 @@
(defun read-conditional (stream subchar int)
(declare (ignore int))
- (cond ((eq subchar (read-feature stream)) (read stream t nil t))
+ (cond ((eq subchar (read-feature stream))
+ (multiple-value-bind (form note) (read-internal stream t nil t)
+ (values form (and note (list note)))))
(t (let* ((*read-suppress* t))
(read stream t nil t)
@@ -2974,20 +2983,20 @@
(set-dispatch-macro-character #\# #\P
- (qlfun |#P-reader| (stream char flags &aux path (invalid-string "Invalid flags (~S) for pathname ~S"))
+ (qlfun |#P-reader| (stream char flags &aux (invalid-string "Invalid flags (~S) for pathname ~S"))
(declare (ignore char))
(when (null flags) (setq flags 0))
(unless (memq flags '(0 1 2 3 4))
(unless *read-suppress* (report-bad-arg flags '(integer 0 4))))
- (setq path (read stream t nil t))
- (unless *read-suppress*
- (unless (stringp path) (report-bad-arg path 'string))
- (setq path (pathname path))
- (when (%ilogbitp 0 flags)
- (when (%pathname-type path) (error invalid-string flags path))
- (setf (%pathname-type path) :unspecific))
- (when (%ilogbitp 1 flags)
- (when (%pathname-name path) (error invalid-string flags path))
- (setf (%pathname-name path) ""))
- path)))
+ (multiple-value-bind (path note) (read-internal stream t nil t)
+ (unless *read-suppress*
+ (unless (stringp path) (report-bad-arg path 'string))
+ (setq path (pathname path))
+ (when (%ilogbitp 0 flags)
+ (when (%pathname-type path) (error invalid-string flags path))
+ (setf (%pathname-type path) :unspecific))
+ (when (%ilogbitp 1 flags)
+ (when (%pathname-name path) (error invalid-string flags path))
+ (setf (%pathname-name path) ""))
+ (values path (and note (list note)))))))
@@ -2999,9 +3008,9 @@
code-coverage
;; The actual form - useful during debugging, perhaps remove later.
- #+debug form
+ #+(or debug gz) form
;; 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 random code form (no file info, generated by macros or other source
- ;; transform), code-note of parent form
+ ;; transform), source-note of parent form
source
;; PC information generated by compiler. For source notes not stored in
@@ -3053,8 +3062,5 @@
(print-unreadable-object (note stream :type t :identity t)
(let ((text (and (source-note-p note) (ignore-errors (source-note-text note)))))
- #+debug (when (and (null text) (code-note-form note))
- (setq text (ignore-errors
- (let ((*print-circle* t))
- (format nil "~s" (code-note-form note))))))
+ #+(or debug gz) (when (null text) (setq text (code-note-form note)))
(when (> (length text) 20)
(let ((end (position #\Newline text :start 20)))
@@ -3136,5 +3142,5 @@
(defun make-source-note (&key form stream start-pos end-pos subform-notes)
- (let ((recording (assoc stream *recording-source-streams*)))
+ (let ((recording (assq stream *recording-source-streams*)))
(when (and recording (not *read-suppress*))
(destructuring-bind (map file-name stream-offset) (cdr recording)
@@ -3164,5 +3170,5 @@
source
(code-note-source source))))))
- #+debug
+ #+(or debug gz)
(when form
(setf (code-note-form note)
Index: /branches/working-0711/ccl/library/cover.lisp
===================================================================
--- /branches/working-0711/ccl/library/cover.lisp (revision 9733)
+++ /branches/working-0711/ccl/library/cover.lisp (revision 9734)
@@ -31,5 +31,5 @@
(cddr entry))
-(defun coverage-subnotes (note)
+(defun coverage-subnotes (note) ;; reversed parent chain
(gethash note *coverage-subnotes*))
@@ -273,5 +273,11 @@
(*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
(*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
- (*entry-code-notes* (make-hash-table :test #'eq :shared nil)))
+ (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
+ (index-file (merge-pathnames output-file "index.html"))
+ (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
+ (pathnamep statistics))
+ (merge-pathnames statistics "statistics.csv")
+ "statistics.csv")
+ output-file))))
(get-coverage)
(ensure-directories-exist directory)
@@ -287,27 +293,29 @@
:if-exists :supersede
:if-does-not-exist :create)
- (report-file-coverage coverage stream external-format))
+ (report-file-coverage index-file coverage stream external-format))
(push (list* src-name html-name coverage) 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"))
- (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
- (pathnamep statistics))
- (merge-pathnames statistics "statistics.csv")
- "statistics.csv")
- output-file))))
- (with-open-file (html-stream index-file
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (if stats-file
- (with-open-file (stats-stream stats-file
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (report-coverage-to-streams paths html-stream stats-stream))
- (report-coverage-to-streams paths html-stream nil)))
- (values index-file stats-file))))
+ (setq paths (sort paths #'(lambda (path1 path2)
+ (let* ((f1 (car path1))
+ (f2 (car path2)))
+ (or (string< (directory-namestring f1)
+ (directory-namestring f2))
+ (and (equal (pathname-directory f1)
+ (pathname-directory f2))
+ (string< (file-namestring f1)
+ (file-namestring f2))))))))
+ (with-open-file (html-stream index-file
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (if stats-file
+ (with-open-file (stats-stream stats-file
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (report-coverage-to-streams paths html-stream stats-stream))
+ (report-coverage-to-streams paths html-stream nil)))
+ (values index-file stats-file)))
(defun report-coverage-to-streams (paths html-stream stats-stream)
@@ -327,5 +335,5 @@
(pathname-directory (pathname prev)))))
(let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name))))
- (format html-stream "| ~A |
~%" dir)
+ (format html-stream "| ~A |
~%" dir)
(when stats-stream (format stats-stream "~a~%" dir))))
do (coverage-stats-data html-stream stats-stream coverage even report-name src-name))
@@ -371,4 +379,22 @@
do (update-text-styles sub styles))))
+(defun entry-note-unambiguous-source (entry-note)
+ ;; Return the nearest containing source note provided it can be done unambiguously.
+ (loop for n = entry-note then parent until (source-note-p n)
+ as parent = (code-note-parent-note n)
+ do (unless (and parent
+ (labels ((no-other-entry-subnotes (n refs)
+ (let ((subs (coverage-subnotes n))
+ (refs (cons n refs)))
+ (declare (dynamic-extent refs))
+ (loop for sub in subs
+ always (or (memq sub refs)
+ (eq sub entry-note)
+ (and (not (entry-code-note-p sub))
+ (no-other-entry-subnotes sub refs)))))))
+ (no-other-entry-subnotes parent ())))
+ (return nil))
+ finally (return n)))
+
(defun colorize-source-note (note styles)
;; Change coverage flag to 'full if all subforms are covered.
@@ -385,19 +411,7 @@
;; So when showing the colorization of an inner function, we usurp the whole nearest source
;; form, provided it can be done unambiguously.
- (loop for n = note then parent until (source-note-p n)
- as parent = (code-note-parent-note n)
- do (unless (and parent
- (labels ((no-other-entry-subnotes (n refs)
- (let ((subs (coverage-subnotes n))
- (refs (cons n refs)))
- (declare (dynamic-extent refs))
- (loop for sub in subs
- always (or (memq sub refs)
- (eq sub note)
- (and (not (entry-code-note-p sub))
- (no-other-entry-subnotes sub refs)))))))
- (no-other-entry-subnotes parent ())))
- (return nil))
- finally (fill-with-text-style (code-note-code-coverage note) n styles))
+ (let ((n (entry-note-unambiguous-source note)))
+ (when n
+ (fill-with-text-style (code-note-code-coverage note) n styles)))
(update-text-styles note styles))
@@ -434,5 +448,5 @@
do (colorize-function imm styles refs))))
-(defun report-file-coverage (coverage html-stream external-format)
+(defun report-file-coverage (index-file coverage html-stream external-format)
"Print a code coverage report of FILE into the stream HTML-STREAM."
(format html-stream "")
@@ -447,11 +461,12 @@
:element-type '(unsigned-byte 2))))
(map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage))
- (print-coverage-report html-stream coverage styles source)
+ (print-file-coverage-report index-file html-stream coverage styles source)
(format html-stream "")))
-(defun print-coverage-report (html-stream coverage styles source)
+(defun print-file-coverage-report (index-file html-stream coverage styles source)
(let ((*print-case* :downcase))
- (format html-stream "Coverage report: ~a
~%
~%" (file-coverage-file coverage))
-
+ (format html-stream "~%"
+ (file-namestring index-file)
+ (file-coverage-file coverage))
(format html-stream "")
(coverage-stats-head html-stream nil)
@@ -500,13 +515,26 @@
(defun coverage-stats-head (html-stream stats-stream)
- (format html-stream " | Expressions | Functions |
")
+ (format html-stream " | ")
+ (format html-stream "Expressions | ")
+ (format html-stream "Branches | ")
+ (format html-stream "Code Forms | ")
+ (format html-stream "Functions |
")
(format html-stream "~{| ~A | ~}
"
- '("Source file"
- "Total" "Covered" "% covered"
- "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered"))
+ '("Source file"
+ ;; Expressions
+ "Total" "Entered" "% entered" "Fully covered" "% fully covered"
+ ;; Branches
+ "Unreached"
+ ;; Code forms
+ "Total" "Covered" "% covered"
+ ;; Functions
+ "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered"))
(when stats-stream
(format stats-stream "~{~a~^,~}"
- '("Source file" "Expressions Total" "Expressions Covered" "% Expressions Covered"
- "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
+ `("Source file"
+ "Expressions Total" "Expressions Entered" "% Expressions Entered"
+ "Unreached Branches"
+ "Code Forms Total" "Code Forms Covered" "% Code Forms Covered"
+ "Functions Total" "Functions Fully Covered" "% Functions Fully Covered"
"Functions Partly Covered" "% Functions Partly Covered"
"Functions Not Entered" "% Functions Not Entered"))))
@@ -519,16 +547,27 @@
(when stats-stream
(format stats-stream "~a," (file-coverage-file coverage)))
- (let ((exp-counts (count-covered-expressions coverage)))
+
+ (let ((exp-counts (count-covered-sexps coverage)))
+ (format html-stream "~{~:[-~;~:*~a~] | ~:[-~;~:*~a~] | ~:[-~;~:*~5,1f%~]~:[-~;~:*~a~] | ~:[-~;~:*~5,1f%~] | ~}" exp-counts)
+ (when stats-stream
+ (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
+
+ (let ((count (count-unreached-branches coverage)))
+ (format html-stream "~:[-~;~:*~a~] | " count)
+ (when stats-stream
+ (format stats-stream "~:[~;~:*~a~]," count)))
+
+ (let ((exp-counts (count-covered-aexps coverage)))
(format html-stream "~{~:[-~;~:*~a~] | ~:[-~;~:*~a~] | ~:[-~;~:*~5,1f%~] | ~}" exp-counts)
(when stats-stream
(format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
- (destructuring-bind (total . counts) (count-covered-functions coverage)
+
+ (destructuring-bind (total . counts) (count-covered-entry-notes coverage)
(format html-stream "~:[-~;~:*~a~] | ~{~:[-~;~:*~a~] | ~:[-~;~:*~5,1f%~] | ~}" total counts)
(when stats-stream
(format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts))))
-(defun count-covered-functions (coverage)
- (let ((fully 0) (partly 0) (never 0) (total 0))
- (map nil #'(lambda (function)
+(defun map-coverage-entry-notes (coverage fn)
+ (map nil #'(lambda (function)
(let ((note (function-entry-code-note function)))
(when (and note
@@ -537,10 +576,18 @@
(code-note-parent-note note)
(code-note-source note)))
- (incf total)
- (case (code-note-code-coverage note)
- ((full) (incf fully))
- ((nil) (incf never))
- (t (incf partly))))))
- (file-coverage-functions coverage))
+ (funcall fn note))))
+ (file-coverage-functions coverage)))
+
+
+(defun count-covered-entry-notes (coverage)
+ (let ((fully 0) (partly 0) (never 0) (total 0))
+ (map-coverage-entry-notes
+ coverage
+ #'(lambda (note)
+ (incf total)
+ (case (code-note-code-coverage note)
+ ((full) (incf fully))
+ ((nil) (incf never))
+ (t (incf partly)))))
(if (> total 0)
(list total
@@ -550,23 +597,54 @@
'(0 0 -- 0 -- 0 --))))
-(defun count-covered-expressions (coverage)
+(defun count-covered-aexps (coverage)
(let ((covered 0) (total 0))
- (map nil #'(lambda (function)
- (let ((note (function-entry-code-note function)))
- (when (and note
- ;; Ignore toplevel functions created by the compiler.
- (or (source-note-p note)
- (code-note-parent-note note)
- (code-note-source note)))
- (labels ((rec (note)
- (incf total)
- (when (code-note-code-coverage note)
- (incf covered))
- (loop for sub in (coverage-subnotes note)
- unless (entry-code-note-p sub) do (rec sub))))
- (rec note)))))
- (file-coverage-functions coverage))
+ (map-coverage-entry-notes
+ coverage
+ (lambda (note)
+ (labels ((rec (note)
+ (incf total)
+ (when (code-note-code-coverage note)
+ (incf covered))
+ (loop for sub in (coverage-subnotes note)
+ unless (entry-code-note-p sub) do (rec sub))))
+ (rec note))))
(list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
+(defun count-covered-sexps (coverage)
+ ;; Count the number of source expressions that have been entered (regardless
+ ;; of whether or not they are completely covered).
+ (let ((entered 0) (covered 0) (total 0))
+ (map-coverage-entry-notes
+ coverage
+ (lambda (note)
+ (labels ((rec (note)
+ (when (source-note-p note)
+ #+debug (format t "~&~s" note)
+ (incf total)
+ (when (code-note-code-coverage note)
+ (incf entered)
+ (when (eq (code-note-code-coverage note) 'full)
+ (incf covered))))
+ (loop for sub in (coverage-subnotes note)
+ unless (entry-code-note-p sub) do (rec sub))))
+ (rec note))))
+ (list total
+ entered (if (> total 0) (* 100.0d0 (/ entered total)) '--)
+ covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
+
+(defun count-unreached-branches (coverage)
+ ;; Count the number of maximal unentered forms
+ (let ((count 0))
+ (map-coverage-entry-notes
+ coverage
+ (lambda (note)
+ (labels ((rec (note parent)
+ (case (code-note-code-coverage note)
+ ((full) nil)
+ ((nil) (when parent (incf count)))
+ (t (loop for sub in (coverage-subnotes note)
+ unless (entry-code-note-p sub) do (rec sub note))))))
+ (rec note nil))))
+ count))
(defun write-coverage-styles (html-stream)