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/27979066cfb973f3c2fa286... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/27979066cfb973f3c2fa286... You're receiving this email because of your account on gitlab.common-lisp.net.