Changeset 9734
- Timestamp:
- Jun 11, 2008, 10:56:56 AM (16 years ago)
- Location:
- branches/working-0711/ccl
- Files:
-
- 4 edited
-
compiler/X86/x862.lisp (modified) (1 diff)
-
level-1/l1-init.lisp (modified) (1 diff)
-
level-1/l1-reader.lisp (modified) (11 diffs)
-
library/cover.lisp (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/compiler/X86/x862.lisp
r9620 r9734 3365 3365 3366 3366 (defun x862-acode-operator-supports-push (form) 3367 ( setq form (acode-unwrapped-form-value form))3368 (when (acode-p form)3369 (if (or (eq form*nx-t*)3370 (eq form*nx-nil*)3371 (let* ((operator (acode-operator form)))3372 (member operator *x862-operator-supports-push*)))3373 form)))3367 (let ((value (acode-unwrapped-form-value form))) 3368 (when (acode-p value) 3369 (if (or (eq value *nx-t*) 3370 (eq value *nx-nil*) 3371 (let* ((operator (acode-operator value))) 3372 (member operator *x862-operator-supports-push*))) 3373 (acode-unwrapped-form form))))) 3374 3374 3375 3375 (defun x862-compare-u8 (seg vreg xfer form u8constant cr-bit true-p u8-operator) -
branches/working-0711/ccl/level-1/l1-init.lisp
r8897 r9734 260 260 (defvar *save-definitions* nil) 261 261 (defvar *save-local-symbols* t) 262 (defvar *save-source-locations* nil262 (defvar *save-source-locations* #+gz t #-gz nil 263 263 "Controls whether complete source locations is stored. 264 264 -
branches/working-0711/ccl/level-1/l1-reader.lisp
r9627 r9734 2602 2602 (lambda (stream ignore) 2603 2603 (declare (ignore ignore)) 2604 `(quote ,(read stream t nil t))))) 2604 (multiple-value-bind (form source-note) 2605 (read-internal stream t nil t) 2606 (values `(quote ,form) (and source-note (list source-note))))))) 2605 2607 2606 2608 (defparameter *alternate-line-terminator* … … 2665 2667 (declare (ignore subchar)) 2666 2668 (if (or (null numarg) *read-suppress*) 2667 (let* ((lst (read-list stream t))2668 2669 (multiple-value-bind (lst notes) (read-list stream t) 2670 (let* ((len (length lst)) 2669 2671 (vec (make-array len))) 2670 2672 (declare (list lst) (fixnum len) (simple-vector vec)) 2671 (dotimes (i len vec) 2672 (setf (svref vec i) (pop lst)))) 2673 (dotimes (i len) 2674 (setf (svref vec i) (pop lst))) 2675 (values vec notes))) 2673 2676 (locally 2674 2677 (declare (fixnum numarg)) 2675 2678 (do* ((vec (make-array numarg)) 2679 (notes ()) 2676 2680 (lastform) 2677 2681 (i 0 (1+ i))) 2678 ((multiple-value-bind (form form-p )2682 ((multiple-value-bind (form form-p source-info) 2679 2683 (%read-list-expression stream nil) 2680 2684 (if form-p 2681 (setq lastform form) 2685 (progn 2686 (setq lastform form) 2687 (when source-info (push source-info notes))) 2682 2688 (unless (= i numarg) 2683 2689 (if (= i 0) … … 2688 2694 (setf (svref vec j) lastform))))) 2689 2695 (not form-p)) 2690 vec)2696 (values vec notes)) 2691 2697 (declare (fixnum i)) 2692 2698 (setf (svref vec i) lastform))))))) … … 2725 2731 #\# 2726 2732 #\C 2727 #'(lambda (stream char arg &aux form)2733 #'(lambda (stream char arg) 2728 2734 (require-no-numarg char arg ) 2729 ( setq form (read stream t nil t))2730 (unless *read-suppress* (apply #'complex form))))2735 (multiple-value-bind (form note) (read-internal stream t nil t) 2736 (values (unless *read-suppress* (apply #'complex form)) (and note (list note)))))) 2731 2737 2732 2738 (set-dispatch-macro-character … … 2812 2818 (lambda (stream subchar numarg) 2813 2819 (require-no-numarg subchar numarg) 2814 `(function ,(read stream t nil t))))) 2820 (multiple-value-bind (form note) (read-internal stream t nil t) 2821 (values `(function ,form) (and note (list note))))))) 2815 2822 2816 2823 (set-dispatch-macro-character … … 2917 2924 (defun read-conditional (stream subchar int) 2918 2925 (declare (ignore int)) 2919 (cond ((eq subchar (read-feature stream)) (read stream t nil t)) 2926 (cond ((eq subchar (read-feature stream)) 2927 (multiple-value-bind (form note) (read-internal stream t nil t) 2928 (values form (and note (list note))))) 2920 2929 (t (let* ((*read-suppress* t)) 2921 2930 (read stream t nil t) … … 2974 2983 2975 2984 (set-dispatch-macro-character #\# #\P 2976 (qlfun |#P-reader| (stream char flags &aux path(invalid-string "Invalid flags (~S) for pathname ~S"))2985 (qlfun |#P-reader| (stream char flags &aux (invalid-string "Invalid flags (~S) for pathname ~S")) 2977 2986 (declare (ignore char)) 2978 2987 (when (null flags) (setq flags 0)) 2979 2988 (unless (memq flags '(0 1 2 3 4)) 2980 2989 (unless *read-suppress* (report-bad-arg flags '(integer 0 4)))) 2981 ( setq path (read stream t nil t))2982 (unless *read-suppress*2983 (unless (stringp path) (report-bad-arg path 'string))2984 (setq path (pathname path))2985 (when (%ilogbitp 0 flags)2986 (when (%pathname-type path) (error invalid-string flags path))2987 (setf (%pathname-type path) :unspecific))2988 (when (%ilogbitp 1 flags)2989 (when (%pathname-name path) (error invalid-string flags path))2990 (setf (%pathname-name path) ""))2991 path)))2990 (multiple-value-bind (path note) (read-internal stream t nil t) 2991 (unless *read-suppress* 2992 (unless (stringp path) (report-bad-arg path 'string)) 2993 (setq path (pathname path)) 2994 (when (%ilogbitp 0 flags) 2995 (when (%pathname-type path) (error invalid-string flags path)) 2996 (setf (%pathname-type path) :unspecific)) 2997 (when (%ilogbitp 1 flags) 2998 (when (%pathname-name path) (error invalid-string flags path)) 2999 (setf (%pathname-name path) "")) 3000 (values path (and note (list note))))))) 2992 3001 2993 3002 … … 2999 3008 code-coverage 3000 3009 ;; The actual form - useful during debugging, perhaps remove later. 3001 #+ debugform3010 #+(or debug gz) form 3002 3011 ;; For the outermost source form, a string (the text of the form). 3003 3012 ;; For an inner source form, the source-note of the outer source form. 3004 3013 ;; For a random code form (no file info, generated by macros or other source 3005 ;; transform), code-note of parent form3014 ;; transform), source-note of parent form 3006 3015 source 3007 3016 ;; PC information generated by compiler. For source notes not stored in … … 3053 3062 (print-unreadable-object (note stream :type t :identity t) 3054 3063 (let ((text (and (source-note-p note) (ignore-errors (source-note-text note))))) 3055 #+debug (when (and (null text) (code-note-form note)) 3056 (setq text (ignore-errors 3057 (let ((*print-circle* t)) 3058 (format nil "~s" (code-note-form note)))))) 3064 #+(or debug gz) (when (null text) (setq text (code-note-form note))) 3059 3065 (when (> (length text) 20) 3060 3066 (let ((end (position #\Newline text :start 20))) … … 3136 3142 3137 3143 (defun make-source-note (&key form stream start-pos end-pos subform-notes) 3138 (let ((recording (ass ocstream *recording-source-streams*)))3144 (let ((recording (assq stream *recording-source-streams*))) 3139 3145 (when (and recording (not *read-suppress*)) 3140 3146 (destructuring-bind (map file-name stream-offset) (cdr recording) … … 3164 3170 source 3165 3171 (code-note-source source)))))) 3166 #+ debug3172 #+(or debug gz) 3167 3173 (when form 3168 3174 (setf (code-note-form note) -
branches/working-0711/ccl/library/cover.lisp
r9578 r9734 31 31 (cddr entry)) 32 32 33 (defun coverage-subnotes (note) 33 (defun coverage-subnotes (note) ;; reversed parent chain 34 34 (gethash note *coverage-subnotes*)) 35 35 … … 273 273 (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) 274 274 (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) 275 (*entry-code-notes* (make-hash-table :test #'eq :shared nil))) 275 (*entry-code-notes* (make-hash-table :test #'eq :shared nil)) 276 (index-file (merge-pathnames output-file "index.html")) 277 (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) 278 (pathnamep statistics)) 279 (merge-pathnames statistics "statistics.csv") 280 "statistics.csv") 281 output-file)))) 276 282 (get-coverage) 277 283 (ensure-directories-exist directory) … … 287 293 :if-exists :supersede 288 294 :if-does-not-exist :create) 289 (report-file-coverage coverage stream external-format))295 (report-file-coverage index-file coverage stream external-format)) 290 296 (push (list* src-name html-name coverage) paths)))) 291 (setq paths (sort paths #'string< :key #'car))292 297 (when (null paths) 293 298 (error "No code coverage data available")) 294 (let* ((index-file (merge-pathnames output-file "index.html")) 295 (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) 296 (pathnamep statistics)) 297 (merge-pathnames statistics "statistics.csv") 298 "statistics.csv") 299 output-file)))) 300 (with-open-file (html-stream index-file 301 :direction :output 302 :if-exists :supersede 303 :if-does-not-exist :create) 304 (if stats-file 305 (with-open-file (stats-stream stats-file 306 :direction :output 307 :if-exists :supersede 308 :if-does-not-exist :create) 309 (report-coverage-to-streams paths html-stream stats-stream)) 310 (report-coverage-to-streams paths html-stream nil))) 311 (values index-file stats-file)))) 299 (setq paths (sort paths #'(lambda (path1 path2) 300 (let* ((f1 (car path1)) 301 (f2 (car path2))) 302 (or (string< (directory-namestring f1) 303 (directory-namestring f2)) 304 (and (equal (pathname-directory f1) 305 (pathname-directory f2)) 306 (string< (file-namestring f1) 307 (file-namestring f2)))))))) 308 (with-open-file (html-stream index-file 309 :direction :output 310 :if-exists :supersede 311 :if-does-not-exist :create) 312 (if stats-file 313 (with-open-file (stats-stream stats-file 314 :direction :output 315 :if-exists :supersede 316 :if-does-not-exist :create) 317 (report-coverage-to-streams paths html-stream stats-stream)) 318 (report-coverage-to-streams paths html-stream nil))) 319 (values index-file stats-file))) 312 320 313 321 (defun report-coverage-to-streams (paths html-stream stats-stream) … … 327 335 (pathname-directory (pathname prev))))) 328 336 (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name)))) 329 (format html-stream "<tr class='subheading'><td colspan='1 1'>~A</td></tr>~%" dir)337 (format html-stream "<tr class='subheading'><td colspan='17'>~A</td></tr>~%" dir) 330 338 (when stats-stream (format stats-stream "~a~%" dir)))) 331 339 do (coverage-stats-data html-stream stats-stream coverage even report-name src-name)) … … 371 379 do (update-text-styles sub styles)))) 372 380 381 (defun entry-note-unambiguous-source (entry-note) 382 ;; Return the nearest containing source note provided it can be done unambiguously. 383 (loop for n = entry-note then parent until (source-note-p n) 384 as parent = (code-note-parent-note n) 385 do (unless (and parent 386 (labels ((no-other-entry-subnotes (n refs) 387 (let ((subs (coverage-subnotes n)) 388 (refs (cons n refs))) 389 (declare (dynamic-extent refs)) 390 (loop for sub in subs 391 always (or (memq sub refs) 392 (eq sub entry-note) 393 (and (not (entry-code-note-p sub)) 394 (no-other-entry-subnotes sub refs))))))) 395 (no-other-entry-subnotes parent ()))) 396 (return nil)) 397 finally (return n))) 398 373 399 (defun colorize-source-note (note styles) 374 400 ;; Change coverage flag to 'full if all subforms are covered. … … 385 411 ;; So when showing the colorization of an inner function, we usurp the whole nearest source 386 412 ;; form, provided it can be done unambiguously. 387 (loop for n = note then parent until (source-note-p n) 388 as parent = (code-note-parent-note n) 389 do (unless (and parent 390 (labels ((no-other-entry-subnotes (n refs) 391 (let ((subs (coverage-subnotes n)) 392 (refs (cons n refs))) 393 (declare (dynamic-extent refs)) 394 (loop for sub in subs 395 always (or (memq sub refs) 396 (eq sub note) 397 (and (not (entry-code-note-p sub)) 398 (no-other-entry-subnotes sub refs))))))) 399 (no-other-entry-subnotes parent ()))) 400 (return nil)) 401 finally (fill-with-text-style (code-note-code-coverage note) n styles)) 413 (let ((n (entry-note-unambiguous-source note))) 414 (when n 415 (fill-with-text-style (code-note-code-coverage note) n styles))) 402 416 (update-text-styles note styles)) 403 417 … … 434 448 do (colorize-function imm styles refs)))) 435 449 436 (defun report-file-coverage ( coverage html-stream external-format)450 (defun report-file-coverage (index-file coverage html-stream external-format) 437 451 "Print a code coverage report of FILE into the stream HTML-STREAM." 438 452 (format html-stream "<html><head>") … … 447 461 :element-type '(unsigned-byte 2)))) 448 462 (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage)) 449 (print- coverage-reporthtml-stream coverage styles source)463 (print-file-coverage-report index-file html-stream coverage styles source) 450 464 (format html-stream "</body></html>"))) 451 465 452 (defun print- coverage-report (html-stream coverage styles source)466 (defun print-file-coverage-report (index-file html-stream coverage styles source) 453 467 (let ((*print-case* :downcase)) 454 (format html-stream "<h3>Coverage report: ~a <br />~%</h3>~%" (file-coverage-file coverage)) 455 468 (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%" 469 (file-namestring index-file) 470 (file-coverage-file coverage)) 456 471 (format html-stream "<table class='summary'>") 457 472 (coverage-stats-head html-stream nil) … … 500 515 501 516 (defun coverage-stats-head (html-stream stats-stream) 502 (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>") 517 (format html-stream "<tr class='head-row'><td></td>") 518 (format html-stream "<td class='main-head' colspan='5'>Expressions</td>") 519 (format html-stream "<td class='main-head' colspan='1'>Branches</td>") 520 (format html-stream "<td class='main-head' colspan='3'>Code Forms</td>") 521 (format html-stream "<td class='main-head' colspan='7'>Functions</td></tr>") 503 522 (format html-stream "<tr class='head-row'>~{<td width='60px'>~A</td>~}</tr>" 504 '("Source file" 505 "Total" "Covered" "% covered" 506 "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")) 523 '("Source file" 524 ;; Expressions 525 "Total" "Entered" "% entered" "Fully covered" "% fully covered" 526 ;; Branches 527 "Unreached" 528 ;; Code forms 529 "Total" "Covered" "% covered" 530 ;; Functions 531 "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered")) 507 532 (when stats-stream 508 533 (format stats-stream "~{~a~^,~}" 509 '("Source file" "Expressions Total" "Expressions Covered" "% Expressions Covered" 510 "Functions Total" "Functions Fully Covered" "% Functions Fully Covered" 534 `("Source file" 535 "Expressions Total" "Expressions Entered" "% Expressions Entered" 536 "Unreached Branches" 537 "Code Forms Total" "Code Forms Covered" "% Code Forms Covered" 538 "Functions Total" "Functions Fully Covered" "% Functions Fully Covered" 511 539 "Functions Partly Covered" "% Functions Partly Covered" 512 540 "Functions Not Entered" "% Functions Not Entered")))) … … 519 547 (when stats-stream 520 548 (format stats-stream "~a," (file-coverage-file coverage))) 521 (let ((exp-counts (count-covered-expressions coverage))) 549 550 (let ((exp-counts (count-covered-sexps coverage))) 551 (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts) 552 (when stats-stream 553 (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) 554 555 (let ((count (count-unreached-branches coverage))) 556 (format html-stream "<td>~:[-~;~:*~a~]</td>" count) 557 (when stats-stream 558 (format stats-stream "~:[~;~:*~a~]," count))) 559 560 (let ((exp-counts (count-covered-aexps coverage))) 522 561 (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts) 523 562 (when stats-stream 524 563 (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) 525 (destructuring-bind (total . counts) (count-covered-functions coverage) 564 565 (destructuring-bind (total . counts) (count-covered-entry-notes coverage) 526 566 (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts) 527 567 (when stats-stream 528 568 (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts)))) 529 569 530 (defun count-covered-functions (coverage) 531 (let ((fully 0) (partly 0) (never 0) (total 0)) 532 (map nil #'(lambda (function) 570 (defun map-coverage-entry-notes (coverage fn) 571 (map nil #'(lambda (function) 533 572 (let ((note (function-entry-code-note function))) 534 573 (when (and note … … 537 576 (code-note-parent-note note) 538 577 (code-note-source note))) 539 (incf total) 540 (case (code-note-code-coverage note) 541 ((full) (incf fully)) 542 ((nil) (incf never)) 543 (t (incf partly)))))) 544 (file-coverage-functions coverage)) 578 (funcall fn note)))) 579 (file-coverage-functions coverage))) 580 581 582 (defun count-covered-entry-notes (coverage) 583 (let ((fully 0) (partly 0) (never 0) (total 0)) 584 (map-coverage-entry-notes 585 coverage 586 #'(lambda (note) 587 (incf total) 588 (case (code-note-code-coverage note) 589 ((full) (incf fully)) 590 ((nil) (incf never)) 591 (t (incf partly))))) 545 592 (if (> total 0) 546 593 (list total … … 550 597 '(0 0 -- 0 -- 0 --)))) 551 598 552 (defun count-covered- expressions (coverage)599 (defun count-covered-aexps (coverage) 553 600 (let ((covered 0) (total 0)) 554 (map nil #'(lambda (function) 555 (let ((note (function-entry-code-note function))) 556 (when (and note 557 ;; Ignore toplevel functions created by the compiler. 558 (or (source-note-p note) 559 (code-note-parent-note note) 560 (code-note-source note))) 561 (labels ((rec (note) 562 (incf total) 563 (when (code-note-code-coverage note) 564 (incf covered)) 565 (loop for sub in (coverage-subnotes note) 566 unless (entry-code-note-p sub) do (rec sub)))) 567 (rec note))))) 568 (file-coverage-functions coverage)) 601 (map-coverage-entry-notes 602 coverage 603 (lambda (note) 604 (labels ((rec (note) 605 (incf total) 606 (when (code-note-code-coverage note) 607 (incf covered)) 608 (loop for sub in (coverage-subnotes note) 609 unless (entry-code-note-p sub) do (rec sub)))) 610 (rec note)))) 569 611 (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) 570 612 613 (defun count-covered-sexps (coverage) 614 ;; Count the number of source expressions that have been entered (regardless 615 ;; of whether or not they are completely covered). 616 (let ((entered 0) (covered 0) (total 0)) 617 (map-coverage-entry-notes 618 coverage 619 (lambda (note) 620 (labels ((rec (note) 621 (when (source-note-p note) 622 #+debug (format t "~&~s" note) 623 (incf total) 624 (when (code-note-code-coverage note) 625 (incf entered) 626 (when (eq (code-note-code-coverage note) 'full) 627 (incf covered)))) 628 (loop for sub in (coverage-subnotes note) 629 unless (entry-code-note-p sub) do (rec sub)))) 630 (rec note)))) 631 (list total 632 entered (if (> total 0) (* 100.0d0 (/ entered total)) '--) 633 covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) 634 635 (defun count-unreached-branches (coverage) 636 ;; Count the number of maximal unentered forms 637 (let ((count 0)) 638 (map-coverage-entry-notes 639 coverage 640 (lambda (note) 641 (labels ((rec (note parent) 642 (case (code-note-code-coverage note) 643 ((full) nil) 644 ((nil) (when parent (incf count))) 645 (t (loop for sub in (coverage-subnotes note) 646 unless (entry-code-note-p sub) do (rec sub note)))))) 647 (rec note nil)))) 648 count)) 571 649 572 650 (defun write-coverage-styles (html-stream)
Note:
See TracChangeset
for help on using the changeset viewer.
