|
| 1 | +(in-package "SI") |
| 2 | + |
| 3 | +(defun search-print-circle (object) |
| 4 | + (multiple-value-bind |
| 5 | + (code present-p) |
| 6 | + (gethash object *circle-stack*) |
| 7 | + (if (not (fixnump *circle-counter*)) |
| 8 | + (cond ((not present-p) |
| 9 | + ;; Was not found before |
| 10 | + (setf (gethash object *circle-stack*) nil) |
| 11 | + 0) |
| 12 | + ((null code) |
| 13 | + ;; Second reference |
| 14 | + (setf (gethash object *circle-stack*) t) |
| 15 | + 1) |
| 16 | + (t |
| 17 | + ;; Further references |
| 18 | + 2)) |
| 19 | + (cond ((or (not present-p) (null code)) |
| 20 | + ;; Is not referenced or was not found before |
| 21 | + 0) |
| 22 | + ((eql code t) |
| 23 | + ;; Reference twice but had no code yet |
| 24 | + (incf *circle-counter*) |
| 25 | + (setf (gethash object *circle-stack*) |
| 26 | + *circle-counter*) |
| 27 | + (- *circle-counter*)) |
| 28 | + (t code))))) |
| 29 | + |
| 30 | +(defun write-object-with-circle (object stream function) |
| 31 | + (if (and *print-circle* |
| 32 | + (not (null object)) |
| 33 | + (not (fixnump object)) |
| 34 | + (not (characterp object)) |
| 35 | + (or (not (symbolp object)) (null (symbol-package object)))) |
| 36 | + ;;; *print-circle* and an object that might have a circle |
| 37 | + (if (null *circle-counter*) |
| 38 | + (let* ((hash (make-hash-table :test 'eq |
| 39 | + :size 1024)) |
| 40 | + (*circle-counter* t) |
| 41 | + (*circle-stack* hash)) |
| 42 | + (write-object-with-circle object (make-broadcast-stream) function) |
| 43 | + (setf *circle-counter* 0) |
| 44 | + (write-object-with-circle object stream function) |
| 45 | + (clrhash hash) |
| 46 | + object) |
| 47 | + (let ((code (search-print-circle object))) |
| 48 | + (cond ((not (fixnump *circle-counter*)) |
| 49 | + ;; We are only inspecting the object to be printed. |
| 50 | + ;; Only print X if it was not referenced before |
| 51 | + (if (not (zerop code)) |
| 52 | + object |
| 53 | + (funcall function object stream))) |
| 54 | + ((zerop code) |
| 55 | + ;; Object is not referenced twice |
| 56 | + (funcall function object stream)) |
| 57 | + ((minusp code) |
| 58 | + ;; Object is referenced twice. We print its definition |
| 59 | + (write-char #\# stream) |
| 60 | + (let ((*print-radix* nil) |
| 61 | + (*print-base* 10)) |
| 62 | + (write-ugly-object (- code) stream)) |
| 63 | + (write-char #\= stream) |
| 64 | + (funcall function object stream)) |
| 65 | + (t |
| 66 | + ;; Second reference to the object |
| 67 | + (write-char #\# stream) |
| 68 | + (let ((*print-radix* nil) |
| 69 | + (*print-base* 10)) |
| 70 | + (write-ugly-object code stream)) |
| 71 | + (write-char #\# stream) |
| 72 | + object)))) |
| 73 | + ;;; live is good, print simple |
| 74 | + (funcall function object stream))) |
0 commit comments