Skip to content
Snippets Groups Projects
Commit 797e2e17 authored by Raymond Toy's avatar Raymond Toy
Browse files

Merge branch 'issue-169-pprint-define-vop' into 'master'

Fix #169: pprint define-vop neatly

Closes #169

See merge request cmucl/cmucl!120
parents 27979066 be6a7f01
No related branches found
No related tags found
No related merge requests found
...@@ -1837,6 +1837,89 @@ When annotations are present, invoke them at the right positions." ...@@ -1837,6 +1837,89 @@ When annotations are present, invoke them at the right positions."
(funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>") (funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>")
stream list)) 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. ;;;; Interface seen by regular (ugly) printer and initialization routines.
...@@ -1952,7 +2035,9 @@ When annotations are present, invoke them at the right positions." ...@@ -1952,7 +2035,9 @@ When annotations are present, invoke them at the right positions."
(vm::with-fixed-allocation pprint-with-like) (vm::with-fixed-allocation pprint-with-like)
(kernel::number-dispatch pprint-with-like) (kernel::number-dispatch pprint-with-like)
(stream::with-stream-class 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 () (defun pprint-init ()
(setf *initial-pprint-dispatch* (make-pprint-dispatch-table)) (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment