Use Inravina pretty printer

.github/workflows/docker.yml

@@ -28,14 +28,14 @@ jobs:
 
       - name: Extract metadata (tags, labels) for Docker
         id: meta
-        uses: docker/metadata-action@8e5442c4ef9f78752691e2d8f8d19755c6f78e81
+        uses: docker/metadata-action@369eb591f429131d6889c46b94e711f089e6ca96
         with:
           images: ghcr.io/clasp-developers/clasp
           tags: |
             type=raw,value=latest
 
       - name: Build and push Docker image
-        uses: docker/build-push-action@4f58ea79222b3b9dc2c8bbdd6debcef730109a75
+        uses: docker/build-push-action@48aba3b46d1b1fec4febb7c5d0c644b249a11355
         with:
           context: docker/clasp/
           push: true

.github/workflows/test.yml

@@ -72,7 +72,7 @@ jobs:
     - name: Checkout repository
       uses: actions/checkout@v4
 
-    - uses: conda-incubator/setup-miniconda@v3.0.4
+    - uses: conda-incubator/setup-miniconda@v3.1.0
       if: matrix.build == 'cando'
 
     - name: Install AmberTools

repos.sexp

@@ -32,6 +32,10 @@
   :repository "https://github.com/trivial-gray-streams/trivial-gray-streams.git"
   :directory "src/lisp/kernel/contrib/trivial-gray-streams/"
   :branch "master")
+ (:name :nontrivial-gray-streams
+  :repository "https://github.com/yitzchak/nontrivial-gray-streams.git"
+  :directory "src/lisp/kernel/contrib/nontrivial-gray-streams/"
+  :branch "main")
  (:name :acclimation
   :repository "https://github.com/robert-strandh/Acclimation.git"
   :directory "src/lisp/kernel/contrib/Acclimation/"
@@ -135,6 +139,18 @@
   :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 :let-plus
   :repository "https://github.com/sharplispers/let-plus.git"
   :directory "src/lisp/kernel/contrib/let-plus/"

src/lisp/cscript.lisp

@@ -120,6 +120,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/cleavir/inline.lisp

@@ -327,25 +327,6 @@
 )
 (declaim (ftype (function (t) function) core:coerce-to-function)))
 
-;;; ------------------------------------------------------------
-;;;
-;;;  Copied from clasp/src/lisp/kernel/lsp/pprint.lisp
-;;;    and put here so that the inline definition is available
-;;;
-(in-package "SI")
-
-#+(or)
-(progn (declaim (inline index-posn posn-index posn-column))
-(defun index-posn (index stream)
-  (declare (type index index) (type pretty-stream stream))
-  (+ index (pretty-stream-buffer-offset stream)))
-(defun posn-index (posn stream)
-  (declare (type posn posn) (type pretty-stream stream))
-  (- posn (pretty-stream-buffer-offset stream)))
-(defun posn-column (posn stream)
-  (declare (type posn posn) (type pretty-stream stream))
-  (index-column (posn-index posn stream) stream))
-
 #+(or)
 (eval-when (:execute)
   (format t "Setting core:*echo-repl-read* to NIL~%")

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/clos/streams.lisp

@@ -934,4 +934,7 @@ truename."))
 
 (pushnew 'gray-streams-module-provider ext:*module-provider-functions*)
 
+#-staging (eval-when (:compile-toplevel :load-toplevel :execute)
+            (require '#:gray-streams))
+
 #+(or cclasp eclasp) (eval-when (:load-toplevel) (setf clos:*clos-booted* t))

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)))