*READ-EVAL* T
*READ-SUPPRESS* NIL
*READTABLE* the standard readtable"
- `(%with-standard-io-syntax #'(lambda () ,@body)))
+ `(%with-standard-io-syntax (lambda () ,@body)))
(defun %with-standard-io-syntax (function)
(let ((*package* (find-package "COMMON-LISP-USER"))
\f
;;;; OUTPUT-OBJECT -- the main entry point
-;;; the current pretty printer. This should be either a function that
-;;; takes two arguments (the object and the stream) or NIL to indicate
-;;; that there is no pretty printer installed.
-(defvar *pretty-printer* nil)
-
;;; Objects whose print representation identifies them EQLly don't
;;; need to be checked for circularity.
(defun uniquely-identified-by-print-p (x)
(defun output-object (object stream)
(labels ((print-it (stream)
(if *print-pretty*
- (if *pretty-printer*
- (funcall *pretty-printer* object stream)
- (let ((*print-pretty* nil))
- (output-ugly-object object stream)))
+ (sb!pretty:output-pretty-object object stream)
(output-ugly-object object stream)))
(check-it (stream)
(multiple-value-bind (marker initiate)
*print-object-is-disabled-p*))
(print-object object stream))
((typep object 'structure-object)
- (default-structure-print object stream *current-level*))
+ (default-structure-print object stream *current-level-in-print*))
(t
(write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
(function
(unless (and (funcallable-instance-p object)
(printed-as-funcallable-standard-class object stream))
- (output-function object stream)))
+ (output-fun object stream)))
(symbol
(output-symbol object stream))
(number
;;; This variable contains the current definition of one of three
;;; symbol printers. SETUP-PRINTER-STATE sets this variable.
-(defvar *internal-symbol-output-function* nil)
+(defvar *internal-symbol-output-fun* nil)
;;; This function sets the internal global symbol
-;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* to the right function depending
-;;; on the value of *PRINT-CASE*. See the manual for details. The
-;;; print buffer stream is also reset.
+;;; *INTERNAL-SYMBOL-OUTPUT-FUN* to the right function depending on
+;;; the value of *PRINT-CASE*. See the manual for details. The print
+;;; buffer stream is also reset.
(defun setup-printer-state ()
(unless (and (eq *print-case* *previous-case*)
(eq (readtable-case *readtable*) *previous-readtable-case*))
(setf (readtable-case *readtable*) :upcase)
(error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*))
- (setq *internal-symbol-output-function*
+ (setq *internal-symbol-output-fun*
(case *previous-readtable-case*
(:upcase
(case *print-case*
(setup-printer-state)
(if (and maybe-quote (symbol-quotep name))
(output-quoted-symbol-name name stream)
- (funcall *internal-symbol-output-function* name stream)))
+ (funcall *internal-symbol-output-fun* name stream)))
\f
;;;; escaping symbols
(when (test letter) (advance OTHER nil))
(go DIGIT))))
\f
-;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION*
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUN*
;;;;
-;;;; Case hackery. These functions are stored in
-;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of
+;;;; case hackery: These functions are stored in
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUN* according to the values of
;;;; *PRINT-CASE* and READTABLE-CASE.
;;; called when:
;;; use until CLOS is set up (at which time it will be replaced with
;;; the real generic function implementation)
(defun print-object (instance stream)
- (default-structure-print instance stream *current-level*))
+ (default-structure-print instance stream *current-level-in-print*))
\f
;;;; integer, ratio, and complex printing (i.e. everything but floats)
(declare (ignore object stream))
nil)
-(defun output-function (object stream)
+(defun output-fun (object stream)
(let* ((*print-length* 3) ; in case we have to..
(*print-level* 3) ; ..print an interpreted function definition
;; FIXME: This find-the-function-name idiom ought to be
;; encapsulated in a function somewhere.
- (name (case (function-subtype object)
+ (name (case (fun-subtype object)
(#.sb!vm:closure-header-widetag "CLOSURE")
(#.sb!vm:simple-fun-header-widetag (%simple-fun-name object))
(t 'no-name-available)))