X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=d715bf12d11ab2caf4a8c38eb409b7bde1ce5079;hb=4fc9d21ae1d8a6a2f8ff70f589d5da103203de13;hp=0c19b98c6c4c1aba408a6ec745285a149c62efdc;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 0c19b98..d715bf1 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -556,13 +556,14 @@
 	  (write-char #\: stream))
 	 ;; Otherwise, if the symbol's home package is the current
 	 ;; one, then a prefix is never necessary.
-	 ((eq package *package*))
+	 ((eq package (sane-package)))
 	 ;; Uninterned symbols print with a leading #:.
 	 ((null package)
 	  (when (or *print-gensym* *print-readably*)
 	    (write-string "#:" stream)))
 	 (t
-	  (multiple-value-bind (symbol accessible) (find-symbol name *package*)
+	  (multiple-value-bind (symbol accessible)
+	      (find-symbol name (sane-package))
 	    ;; If we can find the symbol by looking it up, it need not
 	    ;; be qualified. This can happen if the symbol has been
 	    ;; inherited from a package other than its home package.
@@ -602,8 +603,6 @@
 (declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
 	       *character-attributes*))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
 ;;; Constants which are a bit-mask for each interesting character attribute.
 (defconstant other-attribute		(ash 1 0)) ; Anything else legal.
 (defconstant number-attribute		(ash 1 1)) ; A numeric digit.
@@ -615,9 +614,11 @@
 (defconstant slash-attribute		(ash 1 7)) ; /
 (defconstant funny-attribute		(ash 1 8)) ; Anything illegal.
 
-;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters that
-;;; don't need to be escaped (according to READTABLE-CASE.)
-(defconstant attribute-names
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters
+;;; that don't need to be escaped (according to READTABLE-CASE.)
+(defparameter *attribute-names*
   `((number . number-attribute) (lowercase . lowercase-attribute)
     (uppercase . uppercase-attribute) (letter . letter-attribute)
     (sign . sign-attribute) (extension . extension-attribute)
@@ -688,9 +689,10 @@
 		       (the fixnum
 			    (logand
 			     (logior ,@(mapcar
-					#'(lambda (x)
-					    (or (cdr (assoc x attribute-names))
-						(error "Blast!")))
+					(lambda (x)
+					  (or (cdr (assoc x
+							  *attribute-names*))
+					      (error "Blast!")))
 					attributes))
 			     bits)))))
 	     (digitp ()
@@ -923,7 +925,7 @@
     (let ((length 0)
 	  (list list))
       (loop
-	(punt-if-too-long length stream)
+	(punt-print-if-too-long length stream)
 	(output-object (pop list) stream)
 	(unless list
 	  (return))
@@ -956,7 +958,7 @@
 	   (dotimes (i (length vector))
 	     (unless (zerop i)
 	       (write-char #\space stream))
-	     (punt-if-too-long i stream)
+	     (punt-print-if-too-long i stream)
 	     (output-object (aref vector i) stream))
 	   (write-string ")" stream)))))
 
@@ -1018,13 +1020,13 @@
 	     (dotimes (i dimension)
 	       (unless (zerop i)
 		 (write-char #\space stream))
-	       (punt-if-too-long i stream)
+	       (punt-print-if-too-long i stream)
 	       (sub-output-array-guts array dimensions stream index)
 	       (incf index count)))
 	   (write-char #\) stream)))))
 
-;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for use
-;;; until CLOS is set up (at which time it will be replaced with
+;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for
+;;; 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*))
@@ -1033,8 +1035,8 @@
 
 (defun output-integer (integer stream)
   ;; FIXME: This UNLESS form should be pulled out into something like
-  ;; GET-REASONABLE-PRINT-BASE, along the lines of GET-REASONABLE-PACKAGE
-  ;; for the *PACKAGE* variable.
+  ;; (SANE-PRINT-BASE), along the lines of (SANE-PACKAGE) for the
+  ;; *PACKAGE* variable.
   (unless (and (fixnump *print-base*)
 	       (< 1 *print-base* 37))
     (let ((obase *print-base*))