Changeset 13965 for trunk/source/lib/pprint.lisp
- Timestamp:
- Jul 15, 2010, 5:37:07 PM (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/lib/pprint.lisp
r13942 r13965 1310 1310 (attempt-to-output xp t t)) 1311 1311 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. 1321 1314 (let* ((old-table *print-pprint-dispatch*) 1322 1315 (rec-pending nil) 1323 ( map (require-type map 'hash-table)))1316 (record (require-type recorder 'function))) 1324 1317 (flet ((rec-pprint (xp object) 1325 1318 #+gz (assert (or (null rec-pending) … … 1339 1332 (setf rec-pending nil)) 1340 1333 (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))) 1349 1336 (return nil)) 1350 1337 do (incf (caar pending) change)))) … … 1358 1345 (*print-pprint-dispatch* (make-pprint-dispatch-table :commit-hook #'rec-commit))) 1359 1346 (set-pprint-dispatch 'cons #'rec-pprint) 1360 ( prin1 form stream)1347 (write-1 form stream) 1361 1348 #+gz (assert (null rec-pending)))) 1362 map))1349 form)) 1363 1350 1364 1351
Note: See TracChangeset
for help on using the changeset viewer.