[Git][cmucl/cmucl][master] 2 commits: Fix #169: pprint define-vop neatly

[Raymond Toy (@rtoy)]

Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
be6a7f01 by Raymond Toy at 2023-02-28T14:39:15+00:00
Fix #169: pprint define-vop neatly

- - - - -
797e2e17 by Raymond Toy at 2023-02-28T14:39:17+00:00
Merge branch 'issue-169-pprint-define-vop' into 'master'

Fix #169: pprint define-vop neatly

Closes #169

See merge request cmucl/cmucl!120
- - - - -


1 changed file:

- src/code/pprint.lisp


Changes:

=====================================
src/code/pprint.lisp
=====================================
@@ -1837,6 +1837,89 @@ When annotations are present, invoke them at the right positions."
   (funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>")
 	   stream list))
 
+(defun pprint-define-vop (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
+    ;; Output "define-vop"
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    ;; Output vop name
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (pprint-newline :mandatory stream)
+    (pprint-indent :block 0 stream)
+    ;; Print out each option starting on a new line
+    (loop
+      (write-char #\space stream)
+      (let ((vop-option (pprint-pop)))
+	;; Figure out what option we have and print it neatly
+	(case (car vop-option)
+	  ((:args :results)
+	   ;; :args and :results print out each arg/result indented neatly
+	   (pprint-logical-block (stream vop-option :prefix "(" :suffix ")")
+	     ;; Output :args/:results
+	     (output-object (pprint-pop) stream)
+	     (pprint-exit-if-list-exhausted)
+	     (write-char #\space stream)
+	     (pprint-indent :current 0 stream)
+	     ;; Print each value indented the same amount so the line
+	     ;; up neatly.
+	     (loop
+	       (output-object (pprint-pop) stream)
+	       (pprint-exit-if-list-exhausted)
+	       (pprint-newline :mandatory stream))))
+	  ((:generator)
+	   (pprint-logical-block (stream vop-option :prefix "(" :suffix ")")
+	     ;; Output :generator
+	     (output-object (pprint-pop) stream)
+	     (pprint-exit-if-list-exhausted)
+	     (write-char #\space stream)
+	     ;; Output cost
+	     (output-object (pprint-pop) stream)
+	     (pprint-exit-if-list-exhausted)
+	     ;; Newline and then the body of the generator
+	     (pprint-newline :mandatory stream)
+	     (write-char #\space stream)
+	     (pprint-indent :current 0 stream)
+	     (loop
+	       (output-object (pprint-pop) stream)
+	       (pprint-exit-if-list-exhausted)
+	       (pprint-newline :mandatory stream))))
+	  (t
+	   ;; Everything else just get printed as usual.
+	   (output-object vop-option stream))))
+      (pprint-exit-if-list-exhausted)
+      (pprint-newline :linear stream))))
+
+(defun pprint-sc-case (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
+    ;; Output "sc-case"
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    ;; Output variable name
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    ;; Start the cases on a new line, indented.
+    (pprint-newline :mandatory stream)
+    (pprint-indent :block 0 stream)
+    ;; Print out each case.
+    (loop
+      (write-char #\space stream)
+      (pprint-logical-block (stream (pprint-pop) :prefix "(" :suffix ")")
+	;; Output the case item
+	(output-object (pprint-pop) stream)
+	(pprint-exit-if-list-exhausted)
+	(pprint-newline :mandatory stream)
+	;; Output everything else, starting on a new line.
+	(loop
+	  (output-object (pprint-pop) stream)
+	  (pprint-exit-if-list-exhausted)
+	  (pprint-newline :mandatory stream)))
+      (pprint-exit-if-list-exhausted)
+      (pprint-newline :mandatory stream))))
 
 ;;;; Interface seen by regular (ugly) printer and initialization routines.
 
@@ -1952,7 +2035,9 @@ When annotations are present, invoke them at the right positions."
     (vm::with-fixed-allocation pprint-with-like)
     (kernel::number-dispatch pprint-with-like)
     (stream::with-stream-class pprint-with-like)
-    (lisp::with-array-data pprint-with-like)))
+    (lisp::with-array-data pprint-with-like)
+    (c:define-vop pprint-define-vop)
+    (c:sc-case pprint-sc-case)))
 
 (defun pprint-init ()
   (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/27979066cfb973f3c2fa286d028a8a92d887be58...797e2e1711282e1b5316838613123305f5917e1a

-- 
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/27979066cfb973f3c2fa286d028a8a92d887be58...797e2e1711282e1b5316838613123305f5917e1a
You're receiving this email because of your account on gitlab.common-lisp.net.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230228/7411121c/attachment-0001.html>