Use Inravina pretty printer

repos.sexp

@@ -7,7 +7,7 @@
 ((:name :ansi-test
   :repository "https://gitlab.common-lisp.net/yitzchak/ansi-test"
   :directory "dependencies/ansi-test/"
-  :branch "add-expected-failures")
+  :branch "inravina")
  (:name :cl-bench
   :repository "https://gitlab.common-lisp.net/ansi-test/cl-bench.git"
   :directory "dependencies/cl-bench/"
@@ -30,7 +30,7 @@
   :branch "master")
  (:name :trivial-gray-streams
   :repository "https://github.com/trivial-gray-streams/trivial-gray-streams.git"
-  :directory "dependencies/trivial-gray-streams/"
+  :directory "src/lisp/kernel/contrib/trivial-gray-streams/"
   :branch "master")
  (:name :acclimation
   :repository "https://github.com/robert-strandh/Acclimation.git"
@@ -115,6 +115,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 "split-interface")
+ (:name :inravina
+  :repository "https://github.com/yitzchak/Inravina.git"
+  :directory "src/lisp/kernel/contrib/Inravina/"
+  :commit "split-interface")
+ (: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/"
@@ -205,4 +221,4 @@
   :repository "https://github.com/seqan/seqan.git"
   :directory "extensions/seqan-clasp/seqan/"
   :branch "master"
-  :extension :seqan-clasp))
+  :extension :seqan-clasp))

src/lisp/cscript.lisp

@@ -126,6 +126,9 @@
              #~"kernel/lsp/source-location.lisp"
              #~"kernel/lsp/defvirtual.lisp"
              #~"kernel/clos/streams.lisp"
+             #~"kernel/lsp/circle.lisp"
+             :incless-native
+             :inravina-intrinsic
              #~"kernel/lsp/pprint.lisp"
              #~"kernel/lsp/format-pprint.lisp"
              #~"kernel/clos/conditions.lisp"

src/lisp/kernel/cleavir/inline.lisp

@@ -412,6 +412,7 @@
 ;;;
 (in-package "SI")
 
+#|
 (declaim (inline index-posn posn-index posn-column))
 (defun index-posn (index stream)
   (declare (type index index) (type pretty-stream stream))
@@ -422,7 +423,7 @@
 (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/streams.lisp

@@ -747,17 +747,18 @@
       (export s p))))
 
 (defun redefine-cl-functions ()
-  "Some functions in CL package are expected to be generic. We make them so."
-  (let ((x (si::package-lock "COMMON-LISP" nil)))
-    (loop for cl-symbol in '#.+conflicting-symbols+
-       with gray-package = (find-package "GRAY")
-       do (unless (typep (fdefinition cl-symbol) 'generic-function) 
-	    (let ((gray-symbol (find-symbol (symbol-name cl-symbol) gray-package)))
-	      (setf (fdefinition cl-symbol) (fdefinition gray-symbol))
-	      (unintern gray-symbol gray-package)
-	      (import cl-symbol gray-package)
-	      (export cl-symbol gray-package))))
-    (si::package-lock "COMMON-LISP" x)
+  "Some functions in CL package are expected to be generic. Make it so number one!"
+  (unless (member :staging *features*)
+    (loop with previous-lock = (si::package-lock "COMMON-LISP" nil)
+          with gray-package = (find-package "GRAY")
+          finally (si::package-lock "COMMON-LISP" previous-lock)
+          for cl-symbol in '#.+conflicting-symbols+
+          for gray-symbol = (find-symbol (symbol-name cl-symbol) gray-package)
+          unless (typep (fdefinition cl-symbol) 'generic-function)
+            do (setf (fdefinition cl-symbol) (fdefinition gray-symbol))
+	       (unintern gray-symbol gray-package)
+               (import cl-symbol gray-package)
+               (export cl-symbol gray-package))    
     nil))
 
 #+(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)))