From 16f3952892fbd7c6ca1acaac3fd6a6897676dcdc Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Thu, 14 Apr 2016 09:33:19 -0400 Subject: [PATCH] Change OUTPUT-UGLY-OBJECT to resemble a pprint function. Invert the argument order so that we don't have to wrap it in a lambda. Also remove OUTPUT-PRETTY-OBJECT. --- build-order.lisp-expr | 6 +++--- src/code/ansi-stream.lisp | 32 ++++++++++++++++++++++++++++++++ src/code/pprint.lisp | 18 +++--------------- src/code/print.lisp | 42 +++++++----------------------------------- 4 files changed, 45 insertions(+), 53 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index ad25e6f20..6344510b0 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -277,7 +277,6 @@ ("src/code/fd-stream" :not-host) ("src/code/stream" :not-host) ("src/code/symbol" :not-host) ; uses STRING-OUTPUT-STREAM - ("src/code/print" :not-host) ("src/code/early-format") ("src/code/defpackage" :not-host) @@ -448,8 +447,6 @@ ("src/code/hash-table") ("src/code/readtable") ("src/code/pathname") - ("src/code/host-pprint") - ("src/code/pprint" :not-host) ;; KLUDGE: Much stuff above here is the type system and/or the INFO ;; system, not really the compiler proper. It might be easier to @@ -658,6 +655,9 @@ ("src/code/bignum-random" :not-host) ; needs "code/random" and ; "code/bignum" ("src/code/target-hash-table" :not-host) ; needs "code/hash-table" + ("src/code/host-pprint") ; defines QUEUED-OP needed by 'pprint' + ("src/code/pprint" :not-host) ; defines WITH-PRETTY-STREAM needed by 'print' + ("src/code/print" :not-host) ("src/code/reader" :not-host) ; needs "code/readtable" ("src/code/target-stream" :not-host) ; needs WHITESPACEP from "code/reader" ("src/code/target-pathname" :not-host) ; needs "code/pathname" diff --git a/src/code/ansi-stream.lisp b/src/code/ansi-stream.lisp index e6bdf8dc9..cfa0a6c45 100644 --- a/src/code/ansi-stream.lisp +++ b/src/code/ansi-stream.lisp @@ -130,3 +130,35 @@ (def!method print-object ((x ansi-stream) stream) (print-unreadable-object (x stream :type t :identity t))) + +(defmacro with-standard-io-syntax (&body body) + #!+sb-doc + "Bind the reader and printer control variables to values that enable READ + to reliably read the results of PRINT. These values are: + + *PACKAGE* the COMMON-LISP-USER package + *PRINT-ARRAY* T + *PRINT-BASE* 10 + *PRINT-CASE* :UPCASE + *PRINT-CIRCLE* NIL + *PRINT-ESCAPE* T + *PRINT-GENSYM* T + *PRINT-LENGTH* NIL + *PRINT-LEVEL* NIL + *PRINT-LINES* NIL + *PRINT-MISER-WIDTH* NIL + *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table + *PRINT-PRETTY* NIL + *PRINT-RADIX* NIL + *PRINT-READABLY* T + *PRINT-RIGHT-MARGIN* NIL + *READ-BASE* 10 + *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT + *READ-EVAL* T + *READ-SUPPRESS* NIL + *READTABLE* the standard readtable + SB-EXT:*SUPPRESS-PRINT-ERRORS* NIL +" + (let ((name (make-symbol "THUNK"))) + `(dx-flet ((,name () ,@body)) + (%with-standard-io-syntax #',name)))) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index c3773a832..502e35cbb 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -709,6 +709,7 @@ line break." ;;;; pprint-dispatch tables +(defglobal *standard-pprint-dispatch-table* nil) (defglobal *initial-pprint-dispatch-table* nil) (defstruct (pprint-dispatch-entry @@ -804,9 +805,7 @@ line break." (return entry))))) (if entry (values (pprint-dispatch-entry-fun entry) t) - (values (lambda (stream object) - (output-ugly-object object stream)) - nil)))) + (values #'output-ugly-object nil)))) (defun assert-not-standard-pprint-dispatch-table (pprint-dispatch operation) (when (eq pprint-dispatch *standard-pprint-dispatch-table*) @@ -889,7 +888,7 @@ line break." (defun pprint-array (stream array) (cond ((and (null *print-array*) (null *print-readably*)) - (output-ugly-object array stream)) + (output-ugly-object stream array)) ((and *print-readably* (not (array-readably-printable-p array))) (if *read-eval* @@ -1365,17 +1364,6 @@ line break." (force-pretty-output stream))))) nil)))) -;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when -;;; *PRINT-PRETTY* is true. -(defun output-pretty-object (object stream) - (multiple-value-bind (fun pretty) (pprint-dispatch object) - (if pretty - (with-pretty-stream (stream) - (funcall fun stream object)) - ;; No point in consing up a pretty stream if we are not using pretty - ;; printing the object after all. - (output-ugly-object object stream)))) - (defun call-logical-block-printer (proc stream prefix per-line-p suffix &optional (object nil obj-supplied-p)) ;; PREFIX and SUFFIX will be checked for stringness by START-LOGICAL-BLOCK. diff --git a/src/code/print.lisp b/src/code/print.lisp index 3e1ba5fd2..35e593eba 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -72,37 +72,6 @@ "Suppress printer errors when the condition is of the type designated by this variable: an unreadable object representing the error is printed instead.") -(defmacro with-standard-io-syntax (&body body) - #!+sb-doc - "Bind the reader and printer control variables to values that enable READ - to reliably read the results of PRINT. These values are: - - *PACKAGE* the COMMON-LISP-USER package - *PRINT-ARRAY* T - *PRINT-BASE* 10 - *PRINT-CASE* :UPCASE - *PRINT-CIRCLE* NIL - *PRINT-ESCAPE* T - *PRINT-GENSYM* T - *PRINT-LENGTH* NIL - *PRINT-LEVEL* NIL - *PRINT-LINES* NIL - *PRINT-MISER-WIDTH* NIL - *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table - *PRINT-PRETTY* NIL - *PRINT-RADIX* NIL - *PRINT-READABLY* T - *PRINT-RIGHT-MARGIN* NIL - *READ-BASE* 10 - *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT - *READ-EVAL* T - *READ-SUPPRESS* NIL - *READTABLE* the standard readtable - SB-EXT:*SUPPRESS-PRINT-ERRORS* NIL -" - `(%with-standard-io-syntax (lambda () ,@body))) - -(defglobal sb!pretty::*standard-pprint-dispatch-table* nil) ;; duplicate defglobal because this file is compiled before "reader" (defglobal *standard-readtable* nil) @@ -313,9 +282,12 @@ variable: an unreadable object representing the error is printed instead.") ;; since the generic function should always receive a stream. (declare (explicit-check)) (labels ((print-it (stream) - (if *print-pretty* - (sb!pretty:output-pretty-object object stream) - (output-ugly-object object stream))) + (multiple-value-bind (fun pretty) + (and *print-pretty* (pprint-dispatch object)) + (if pretty + (sb!pretty::with-pretty-stream (stream) + (funcall fun stream object)) + (output-ugly-object stream object)))) (handle-it (stream) (if *suppress-print-errors* (handler-bind ((condition @@ -381,7 +353,7 @@ variable: an unreadable object representing the error is printed instead.") ;;; except for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL, ;;; then the pretty printer will be used for any components of OBJECT, ;;; just not for OBJECT itself. -(defun output-ugly-object (object stream) +(defun output-ugly-object (stream object) (typecase object ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of ;; PRINT-OBJECT says it provides printing and we're supposed to provide -- 2.11.4.GIT