Use Inravina pretty printer

Author: yitzchak

repos.sexp

@@ -135,6 +135,22 @@
   :directory "src/lisp/kernel/contrib/global-vars/"
   :commit "c749f32c9b606a1457daa47d59630708ac0c266e"
   :extension :cando)
+ (:name :incless
+  :repository "https://github.com/s-expressionists/Incless.git"
+  :directory "src/lisp/kernel/contrib/Incless/"
+  :commit "main")
+ (:name :inravina
+  :repository "https://github.com/s-expressionists/Inravina.git"
+  :directory "src/lisp/kernel/contrib/Inravina/"
+  :commit "main")
+ (:name :trivial-package-locks
+  :repository "https://github.com/yitzchak/trivial-package-locks.git"
+  :directory "src/lisp/kernel/contrib/trivial-package-locks/"
+  :commit "main")
+ (:name :trivial-stream-column
+  :repository "https://github.com/yitzchak/trivial-stream-column.git"
+  :directory "src/lisp/kernel/contrib/trivial-stream-column/"
+  :commit "main")
  (:name :let-plus
   :repository "https://github.com/sharplispers/let-plus.git"
   :directory "src/lisp/kernel/contrib/let-plus/"

src/lisp/cscript.lisp

@@ -123,6 +123,8 @@
              #~"kernel/lsp/source-location.lisp"
              #~"kernel/lsp/defvirtual.lisp"
              #~"kernel/clos/streams.lisp"
+             #~"kernel/lsp/circle.lisp"
+             :inravina-shim
              #~"kernel/lsp/pprint.lisp"
              #~"kernel/lsp/format-pprint.lisp"
              #~"kernel/clos/conditions.lisp"

src/lisp/kernel/clos/print.lisp

@@ -241,7 +241,7 @@ printer and we should rather use MAKE-LOAD-FORM."
     (write (eql-specializer-object es) :stream stream))
   es)
 
-(defmethod print-object ((obj structure-object) stream)
+(defun print-structure-object (obj stream)
   (let* ((class (si:instance-class obj))
 	 (slotds (class-slots class)))
     (when (and ;; to fix ansi-tests PRINT-LEVEL.8 & PRINT-LEVEL.9
@@ -252,7 +252,7 @@ printer and we should rather use MAKE-LOAD-FORM."
            *print-level*
            (zerop *print-level*))
       (write-string "#" stream)
-      (return-from print-object obj))
+      (return-from print-structure-object obj))
     (write-string "#S(" stream)
     (prin1 (class-name class) stream)
     (do ((scan slotds (cdr scan))
@@ -279,6 +279,9 @@ printer and we should rather use MAKE-LOAD-FORM."
     (write-string ")" stream)
     obj))
 
+(defmethod print-object ((obj structure-object) stream)
+  (print-structure-object obj stream))
+
 (defmethod print-object ((object standard-object) stream)
   (print-unreadable-object (object stream :type t :identity t))
   object)

src/lisp/kernel/lsp/circle.lisp

@@ -0,0 +1,74 @@
+(in-package "SI")
+
+(defun search-print-circle (object)
+  (multiple-value-bind
+        (code present-p)
+      (gethash object *circle-stack*)
+    (if (not (fixnump *circle-counter*))
+        (cond ((not present-p)
+	       ;; Was not found before
+	       (setf (gethash object *circle-stack*) nil)
+	       0)
+	      ((null code)
+	       ;; Second reference
+	       (setf (gethash object *circle-stack*) t)
+	       1)
+	      (t
+	       ;; Further references
+	       2))
+	(cond ((or (not present-p) (null code))
+	       ;; Is not referenced or was not found before
+	       0)
+	      ((eql code t)
+	       ;; Reference twice but had no code yet
+               (incf *circle-counter*)
+	       (setf (gethash object *circle-stack*)
+		     *circle-counter*)
+	       (- *circle-counter*))
+	      (t code)))))
+	       
+(defun write-object-with-circle (object stream function)
+  (if (and *print-circle*
+           (not (null object))
+           (not (fixnump object))
+           (not (characterp object))
+           (or (not (symbolp object)) (null (symbol-package object))))
+            ;;; *print-circle* and an object that might have a circle
+      (if (null *circle-counter*)
+          (let* ((hash (make-hash-table :test 'eq
+                                        :size 1024))
+                 (*circle-counter* t)
+                 (*circle-stack* hash))
+            (write-object-with-circle object (make-broadcast-stream) function)
+            (setf *circle-counter* 0)
+            (write-object-with-circle object stream function)
+            (clrhash hash)
+            object)
+          (let ((code (search-print-circle object)))
+            (cond ((not (fixnump *circle-counter*))
+                   ;; We are only inspecting the object to be printed.
+                   ;; Only print X if it was not referenced before
+                   (if (not (zerop code))
+                       object
+                       (funcall function object stream)))
+                  ((zerop code)
+                   ;; Object is not referenced twice
+                   (funcall function object stream))
+                  ((minusp code)
+                   ;; Object is referenced twice. We print its definition 
+                   (write-char #\# stream)
+                   (let ((*print-radix* nil)
+                         (*print-base* 10))
+                     (write-ugly-object (- code) stream))
+                   (write-char #\= stream)
+                   (funcall function object stream))
+                  (t
+                   ;; Second reference to the object
+                   (write-char #\# stream)
+                   (let ((*print-radix* nil)
+                         (*print-base* 10))
+                     (write-ugly-object code stream))
+                   (write-char #\# stream)
+                   object))))
+      ;;; live is good, print simple
+      (funcall function object stream)))