Ignore:
Timestamp:
Jul 15, 2010, 5:37:07 PM (9 years ago)
Author:
gz
Message:

Change pprint-recording-positions to take a function to do the recording

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/pprint.lisp

    r13942 r13965  
    13101310  (attempt-to-output xp t t))
    13111311
    1312 
    1313 ;; pretty-print FORM into STREAM, recording file positions for objects (actually conses only) in MAP.
    1314 ;; if ADD-NEW is false, MAP should be pre-populated and only those objects with entries in MAP
    1315 ;; will be tracked.
    1316 ;; The hair here comes from the fact that the pretty printer backtracks to insert newlines.
    1317 (defun pprint-recording-positions (form stream &key map (add-new t))
    1318   (when (null map)
    1319     (assert add-new () ":MAP required")
    1320     (setq map (make-hash-table :test #'eq)))
     1312(defun pprint-recording-positions (form stream recorder)
     1313  ;; The hair here comes from the fact that the pretty printer backtracks to insert newlines.
    13211314  (let* ((old-table *print-pprint-dispatch*)
    13221315         (rec-pending nil)
    1323          (map (require-type map 'hash-table)))
     1316         (record (require-type recorder 'function)))
    13241317    (flet ((rec-pprint (xp object)
    13251318             #+gz (assert (or (null rec-pending)
     
    13391332                      (setf rec-pending nil))
    13401333                    (loop with start = (stream-position (xp-out-stream xp))
    1341                       for (offset open-p . object) in pending
    1342                       as cell = (or (gethash object map)
    1343                                     (and add-new
    1344                                          (setf (gethash object map) (cons nil nil))))
    1345                       when cell
    1346                       do (if open-p
    1347                            (setf (car cell) (+ start offset))
    1348                            (setf (cdr cell) (+ start offset))))
     1334                      for (offset open-p . object) in (nreverse pending)
     1335                      do (funcall record object open-p (+ start offset)))
    13491336                    (return nil))
    13501337               do (incf (caar pending) change))))
     
    13581345             (*print-pprint-dispatch* (make-pprint-dispatch-table :commit-hook #'rec-commit)))
    13591346        (set-pprint-dispatch 'cons #'rec-pprint)
    1360         (prin1 form stream)
     1347        (write-1 form stream)
    13611348        #+gz (assert (null rec-pending))))
    1362     map))
     1349    form))
    13631350
    13641351
Note: See TracChangeset for help on using the changeset viewer.