Ignore:
Timestamp:
Jul 27, 2010, 2:21:17 AM (9 years ago)
Author:
gz
Message:

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

Location:
branches/qres/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/lib/pprint.lisp

    r11834 r14058  
    175175  (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
    176176  (structures (make-hash-table :test #'eq) :type (or null hash-table))
    177   (others nil :type list))
     177  (others nil :type list)
     178  (commit-hook nil))
    178179
    179180;The list and the hash-tables contain entries of the
     
    199200      :conses-with-cars new-conses-with-cars
    200201      :structures new-structures
    201       :others (copy-list (others table)))))
     202      :others (copy-list (others table))
     203      :commit-hook (commit-hook table))))
    202204
    203205
     
    939941                          (maybe-too-large xp qleft queue linel)))
    940942               (T T)) ;(:linear :unconditional :mandatory)
    941          (output-line xp qleft)
    942          (setup-for-next-line xp qleft))))
     943         (output-line-and-setup-for-next xp qleft))))
    943944    (setf (xp-qleft xp) (setq qleft (qnext qleft))))
    944945  (when flush-out? (flush xp)))))
     
    947948
    948949(defun flush (xp)
    949   (let ((ostream (xp-out-stream xp)))
     950  (let ((ostream (xp-out-stream xp))
     951        (len (xp-buffer-ptr xp)))
     952    (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*))
     953      (funcall (commit-hook *print-pprint-dispatch*) xp len 0))
    950954    (when ostream     
    951       (write-string (xp-buffer xp) ostream :start 0 :end (xp-buffer-ptr xp)))
    952     (incf (xp-buffer-offset xp) (xp-buffer-ptr xp))
    953     (incf (xp-charpos xp) (xp-buffer-ptr xp))
     955      (write-string (xp-buffer xp) ostream :start 0 :end len))
     956    (incf (xp-buffer-offset xp) len)
     957    (incf (xp-charpos xp) len)
    954958    (setf (xp-buffer-ptr xp) 0)))
    955959
     
    968972;This prints out a line of stuff.
    969973
    970 (defun output-line (xp Qentry)
    971   (flet ((find-not-char-reverse (buffer out-point)
    972            (declare (type simple-base-string buffer) (type fixnum out-point))
    973            (do ((i (%i- out-point 1) (%i- i 1)))
    974                ((%i< i 0) nil)
    975              (when (or (neq (schar buffer i) #\Space)
    976                        ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be
    977                        ;; quoted; don't bother checking for that, no big harm leaving the space even if
    978                        ;; not totally necessary).
    979                        (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\)))
    980                (return i)))))
    981     (let* ((queue (xp-queue xp))
    982            (out-point (BP<-TP xp (xpq-pos queue Qentry)))
    983            (last-non-blank (find-not-char-reverse (xp-buffer xp) out-point))
    984            (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point)
    985                       (last-non-blank (%i+ 1 last-non-blank))
    986                       (T 0)))
    987            (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
    988       (when line-limit-exit
    989         (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
    990         (write-string+++ " .." xp 0 3)
    991         (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
    992         (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
    993         (setf (xp-qleft xp) (qnext (xp-qright xp)))
    994         ;(setq *abbreviation-happened* '*print-lines*)
    995         (throw 'line-limit-abbreviation-exit T))
    996       (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
    997       (let ((bstream (xp-out-stream xp)))
    998         (when bstream
    999           (write-string (xp-buffer xp) bstream :start 0 :end end)
    1000           (stream-write-char bstream #\newline))))))
    1001 
    1002 (defun setup-for-next-line (xp Qentry)
     974(defun output-line-and-setup-for-next (xp Qentry)
    1003975  (let* ((queue (xp-queue xp))
    1004976         (out-point (BP<-TP xp (xpq-pos queue Qentry)))
    1005          (prefix-end
    1006           (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh))
    1007                  (non-blank-prefix-ptr xp))
    1008                 (T (prefix-ptr xp))))
    1009          (change (- prefix-end out-point)))
    1010     (declare (fixnum out-point prefix-end change))
     977         (unconditional-p (memq (xpq-kind queue Qentry) '(:fresh :unconditional)))
     978         (end (if unconditional-p
     979                out-point
     980                (let ((buffer (xp-buffer xp)))
     981                  (declare (type simple-base-string buffer))
     982                  (do ((i (%i- out-point 1) (%i- i 1)))
     983                      ((%i< i 0) 0)
     984                    (when (or (neq (schar buffer i) #\Space)
     985                              ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be
     986                              ;; quoted; don't bother checking for that, no big harm leaving the space even if
     987                              ;; not totally necessary).
     988                              (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\)))
     989                      (return (%i+ i 1)))))))
     990         (prefix-end
     991          (if unconditional-p (non-blank-prefix-ptr xp) (prefix-ptr xp)))
     992         (old-ptr (xp-buffer-ptr xp))
     993         (new-ptr (%i+ old-ptr (%i- prefix-end out-point)))
     994         (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp))))))
     995    (when line-limit-exit
     996      (setf (xp-buffer-ptr xp) end)          ;truncate pending output.
     997      (write-string+++ " .." xp 0 3)
     998      (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp))
     999      (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp))
     1000      (setf (xp-qleft xp) (qnext (xp-qright xp)))
     1001      ;(setq *abbreviation-happened* '*print-lines*)
     1002      (throw 'line-limit-abbreviation-exit T))
     1003    (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp)))
     1004    (when (and *print-pprint-dispatch* (commit-hook *print-pprint-dispatch*))
     1005      (funcall (commit-hook *print-pprint-dispatch*) xp out-point prefix-end))
     1006    (let ((bstream (xp-out-stream xp)))
     1007      (when bstream
     1008        (write-string (xp-buffer xp) bstream :start 0 :end end)
     1009        (stream-write-char bstream #\newline)))
    10111010    (setf (xp-charpos xp) 0)
    1012     (when (plusp change)                  ;almost never happens
    1013       (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change)
    1014                      #.buffer-min-size #.buffer-entry-size))
     1011    (when (%i> new-ptr old-ptr)                  ;almost never happens
     1012      (xp-check-size (xp-buffer xp) new-ptr #.buffer-min-size #.buffer-entry-size))
     1013    (setf (xp-buffer-ptr xp) new-ptr)
     1014    (decf (xp-buffer-offset xp) (- prefix-end out-point))
    10151015    (let ((buffer (xp-buffer xp)))
    1016       (replace buffer buffer :start1 prefix-end
    1017                :start2 out-point :end2 (xp-buffer-ptr xp))
     1016      (replace buffer buffer :start1 prefix-end :start2 out-point :end2 old-ptr)
    10181017      (replace buffer (xp-prefix xp) :end2 prefix-end)
    1019       (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change))
    1020       (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change))
    1021       (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh)))
     1018      (unless unconditional-p
    10221019        (setf (section-start-line xp) (xp-line-no xp))))))
     1020
     1021
    10231022
    10241023(defun set-indentation-prefix (xp new-position)
     
    13101309(defmethod stream-finish-output ((xp xp-structure))
    13111310  (attempt-to-output xp t t))
     1311
     1312(defun pprint-recording-positions (form stream recorder)
     1313  ;; The hair here comes from the fact that the pretty printer backtracks to insert newlines.
     1314  (let* ((old-table *print-pprint-dispatch*)
     1315         (rec-pending nil)
     1316         (record (require-type recorder 'function)))
     1317    (flet ((rec-pprint (xp object)
     1318             #+gz (assert (or (null rec-pending)
     1319                              (<= (caar rec-pending) (xp-buffer-ptr xp))))
     1320             (let ((real-printer (get-printer object old-table)))
     1321               (when real-printer
     1322                 (push (list* (xp-buffer-ptr xp) t object) rec-pending)
     1323                 (funcall real-printer xp object)
     1324                 (push (list* (xp-buffer-ptr xp) nil object) rec-pending))))
     1325           (rec-commit (xp commited inserted)
     1326             (loop with change = (- inserted commited)
     1327               as last = nil then pending
     1328               as pending = rec-pending then (cdr pending) while pending
     1329               do (when (<= (caar pending) commited) ;; commit the rest.
     1330                    (if last
     1331                      (setf (cdr last) nil)
     1332                      (setf rec-pending nil))
     1333                    (loop with start = (stream-position (xp-out-stream xp))
     1334                      for (offset open-p . object) in (nreverse pending)
     1335                      do (funcall record object open-p (+ start offset)))
     1336                    (return nil))
     1337               do (incf (caar pending) change))))
     1338      (let* ((*print-pretty* t)
     1339             (*print-circle* nil)
     1340             (*print-length* nil)
     1341             (*print-level* nil)
     1342             (*print-lines* nil)
     1343             (*print-miser-width* nil)
     1344             (*read-suppress* nil)
     1345             (*print-pprint-dispatch* (make-pprint-dispatch-table :commit-hook #'rec-commit)))
     1346        (set-pprint-dispatch 'cons #'rec-pprint)
     1347        (write-1 form stream)
     1348        #+gz (assert (null rec-pending))))
     1349    form))
     1350
    13121351
    13131352
Note: See TracChangeset for help on using the changeset viewer.