X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fprint.lisp;h=018cf57f29c9eae3f5de04761994faf2bcbed2e3;hb=3fe0010d2777b41e01ea9b4a0f894cfa40f7df1b;hp=7da9efefc226089ec5649aa39791b02dec948c74;hpb=079ef9dad558ca07cb8178ef428bf738112174fa;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 7da9efe..018cf57 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -21,7 +21,7 @@ "If true, all objects will printed readably. If readable printing is impossible, an error will be signalled. This overrides the value of *PRINT-ESCAPE*.") -(defvar *print-escape* T +(defvar *print-escape* t #!+sb-doc "Should we print in a reasonably machine-readable way? (possibly overridden by *PRINT-READABLY*)") @@ -230,16 +230,11 @@ ;;; This produces the printed representation of an object as a string. ;;; The few ...-TO-STRING functions above call this. -(defvar *string-output-streams* ()) (defun stringify-object (object) - (let ((stream (if *string-output-streams* - (pop *string-output-streams*) - (make-string-output-stream)))) + (let ((stream (make-string-output-stream))) (setup-printer-state) (output-object object stream) - (prog1 - (get-output-stream-string stream) - (push stream *string-output-streams*)))) + (get-output-stream-string stream))) ;;;; support for the PRINT-UNREADABLE-OBJECT macro @@ -275,108 +270,6 @@ (write-char #\> stream)))) nil) -;;;; circularity detection stuff - -;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that -;;; (eventually) ends up with entries for every object printed. When -;;; we are initially looking for circularities, we enter a T when we -;;; find an object for the first time, and a 0 when we encounter an -;;; object a second time around. When we are actually printing, the 0 -;;; entries get changed to the actual marker value when they are first -;;; printed. -(defvar *circularity-hash-table* nil) - -;;; When NIL, we are just looking for circularities. After we have -;;; found them all, this gets bound to 0. Then whenever we need a new -;;; marker, it is incremented. -(defvar *circularity-counter* nil) - -;;; Check to see whether OBJECT is a circular reference, and return -;;; something non-NIL if it is. If ASSIGN is T, then the number to use -;;; in the #n= and #n# noise is assigned at this time. -;;; If ASSIGN is true, reference bookkeeping will only be done for -;;; existing entries, no new references will be recorded! -;;; -;;; Note: CHECK-FOR-CIRCULARITY must be called *exactly* once with -;;; ASSIGN true, or the circularity detection noise will get confused -;;; about when to use #n= and when to use #n#. If this returns non-NIL -;;; when ASSIGN is true, then you must call HANDLE-CIRCULARITY on it. -;;; If CHECK-FOR-CIRCULARITY returns :INITIATE as the second value, -;;; you need to initiate the circularity detection noise, e.g. bind -;;; *CIRCULARITY-HASH-TABLE* and *CIRCULARITY-COUNTER* to suitable values -;;; (see #'OUTPUT-OBJECT for an example). -(defun check-for-circularity (object &optional assign) - (cond ((null *print-circle*) - ;; Don't bother, nobody cares. - nil) - ((null *circularity-hash-table*) - (values nil :initiate)) - ((null *circularity-counter*) - (ecase (gethash object *circularity-hash-table*) - ((nil) - ;; first encounter - (setf (gethash object *circularity-hash-table*) t) - ;; We need to keep looking. - nil) - ((t) - ;; second encounter - (setf (gethash object *circularity-hash-table*) 0) - ;; It's a circular reference. - t) - (0 - ;; It's a circular reference. - t))) - (t - (let ((value (gethash object *circularity-hash-table*))) - (case value - ((nil t) - ;; If NIL, we found an object that wasn't there the - ;; first time around. If T, this object appears exactly - ;; once. Either way, just print the thing without any - ;; special processing. Note: you might argue that - ;; finding a new object means that something is broken, - ;; but this can happen. If someone uses the ~@<...~:> - ;; format directive, it conses a new list each time - ;; though format (i.e. the &REST list), so we will have - ;; different cdrs. - nil) - (0 - (if assign - (let ((value (incf *circularity-counter*))) - ;; first occurrence of this object: Set the counter. - (setf (gethash object *circularity-hash-table*) value) - value) - t)) - (t - ;; second or later occurrence - (- value))))))) - -;;; Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then -;;; you should go ahead and print the object. If it returns NIL, then -;;; you should blow it off. -(defun handle-circularity (marker stream) - (case marker - (:initiate - ;; Someone forgot to initiate circularity detection. - (let ((*print-circle* nil)) - (error "trying to use CHECK-FOR-CIRCULARITY when ~ - circularity checking isn't initiated"))) - ((t) - ;; It's a second (or later) reference to the object while we are - ;; just looking. So don't bother groveling it again. - nil) - (t - (write-char #\# stream) - (let ((*print-base* 10) (*print-radix* nil)) - (cond ((minusp marker) - (output-integer (- marker) stream) - (write-char #\# stream) - nil) - (t - (output-integer marker stream) - (write-char #\= stream) - t)))))) - ;;;; OUTPUT-OBJECT -- the main entry point ;;; Objects whose print representation identifies them EQLly don't @@ -394,9 +287,8 @@ (sb!pretty:output-pretty-object object stream) (output-ugly-object object stream))) (check-it (stream) - (multiple-value-bind (marker initiate) - (check-for-circularity object t) - ;; initialization of the circulation detect noise ... + (multiple-value-bind (marker initiate) + (check-for-circularity object t) (if (eq initiate :initiate) (let ((*circularity-hash-table* (make-hash-table :test 'eq))) @@ -1630,23 +1522,15 @@ nil) (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 (fun-subtype object) - (#.sb!vm:closure-header-widetag "CLOSURE") - (#.sb!vm:simple-fun-header-widetag (%simple-fun-name object)) - (t 'no-name-available))) - (identified-by-name-p (and (symbolp name) - (fboundp name) - (eq (fdefinition name) object)))) - (print-unreadable-object (object - stream - :identity (not identified-by-name-p)) - (prin1 'function stream) - (unless (eq name 'no-name-available) - (format stream " ~S" name))))) + (let* ((*print-length* 3) ; in case we have to.. + (*print-level* 3) ; ..print an interpreted function definition + (name (%fun-name object)) + (proper-name-p (and (legal-fun-name-p name) (fboundp name) + (eq (fdefinition name) object)))) + (print-unreadable-object (object stream :identity (not proper-name-p)) + (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" + (closurep object) + name)))) ;;;; catch-all for unknown things