X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=d27924ae6358228662533fb53386ab5673081ad1;hb=56a972e201d117a8d5d769527f2bafd23cba7de9;hp=0acd17680d7e9d8af0594f9a26ff28a05268c98a;hpb=835e0272eaedd4764be992fe2d1cde078d581ce1;p=sbcl.git

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 0acd176..d27924a 100644
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -66,9 +66,10 @@
    is less than this, then print using ``miser-style'' output. Miser
    style conditional newlines are turned on, and all indentations are
    turned off. If NIL, never use miser mode.")
-(defvar *print-pprint-dispatch* nil
-  #!+sb-doc
-  "the pprint-dispatch-table that controls how to pretty-print objects")
+(defvar *print-pprint-dispatch*)
+#!+sb-doc
+(setf (fdocumentation '*print-pprint-dispatch* 'variable)
+      "the pprint-dispatch-table that controls how to pretty-print objects")
 
 (defmacro with-standard-io-syntax (&body body)
   #!+sb-doc
@@ -596,7 +597,7 @@
 ;;; words, diddle its case according to *PRINT-CASE* and
 ;;; READTABLE-CASE.
 (defun output-symbol-name (name stream &optional (maybe-quote t))
-  (declare (type simple-base-string name))
+  (declare (type simple-string name))
   (setup-printer-state)
   (if (and maybe-quote (symbol-quotep name))
       (output-quoted-symbol-name name stream)
@@ -874,19 +875,19 @@
 ;;; :DOWNCASE		:CAPITALIZE
 (defun output-capitalize-symbol (pname stream)
   (declare (simple-string pname))
-  (let ((prev-not-alpha t)
+  (let ((prev-not-alphanum t)
 	(up (eq (readtable-case *readtable*) :upcase)))
     (dotimes (i (length pname))
       (let ((char (char pname i)))
 	(write-char (if up
-			(if (or prev-not-alpha (lower-case-p char))
+			(if (or prev-not-alphanum (lower-case-p char))
 			    char
 			    (char-downcase char))
-			(if prev-not-alpha
+			(if prev-not-alphanum
 			    (char-upcase char)
 			    char))
 		    stream)
-	(setq prev-not-alpha (not (alpha-char-p char)))))))
+	(setq prev-not-alphanum (not (alphanumericp char)))))))
 
 ;;; called when:
 ;;; READTABLE-CASE	*PRINT-CASE*
@@ -975,7 +976,7 @@
 	   (write-char (if (zerop bit) #\0 #\1) stream)))
 	(t
 	 (when (and *print-readably*
-		    (not (array-readably-printable-p array)))
+		    (not (array-readably-printable-p vector)))
 	   (error 'print-not-readable :object vector))
 	 (descend-into (stream)
 		       (write-string "#(" stream)
@@ -1162,8 +1163,8 @@
       (2 (write-char #\b stream))
       (8 (write-char #\o stream))
       (16 (write-char #\x stream))
-      (t (write *print-base* :stream stream :radix nil :base 10)))
-    (write-char #\r stream))
+      (t (write *print-base* :stream stream :radix nil :base 10)
+	 (write-char #\r stream))))
   (let ((*print-radix* nil))
     (output-integer (numerator ratio) stream)
     (write-char #\/ stream)
@@ -1391,30 +1392,40 @@
 ;;; part of the computation to avoid over/under flow. When
 ;;; denormalized, we must pull out a large factor, since there is more
 ;;; negative exponent range than positive range.
+
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format*
+	#!+long-float 'long-float #!-long-float 'double-float))
 (defun scale-exponent (original-x)
   (let* ((x (coerce original-x 'long-float)))
     (multiple-value-bind (sig exponent) (decode-float x)
       (declare (ignore sig))
-      (if (= x 0.0l0)
-	  (values (float 0.0l0 original-x) 1)
-	  (let* ((ex (round (* exponent (log 2l0 10))))
+      (if (= x 0.0e0)
+	  (values (float 0.0e0 original-x) 1)
+	  (let* ((ex (locally (declare (optimize (safety 0)))
+                       (the fixnum
+                         (round (* exponent (log 2e0 10))))))
 		 (x (if (minusp ex)
 			(if (float-denormalized-p x)
 			    #!-long-float
-			    (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
+			    (* x 1.0e16 (expt 10.0e0 (- (- ex) 16)))
 			    #!+long-float
-			    (* x 1.0l18 (expt 10.0l0 (- (- ex) 18)))
-			    (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
-			(/ x 10.0l0 (expt 10.0l0 (1- ex))))))
-	    (do ((d 10.0l0 (* d 10.0l0))
+			    (* x 1.0e18 (expt 10.0e0 (- (- ex) 18)))
+			    (* x 10.0e0 (expt 10.0e0 (- (- ex) 1))))
+			(/ x 10.0e0 (expt 10.0e0 (1- ex))))))
+	    (do ((d 10.0e0 (* d 10.0e0))
 		 (y x (/ x d))
 		 (ex ex (1+ ex)))
-		((< y 1.0l0)
-		 (do ((m 10.0l0 (* m 10.0l0))
+		((< y 1.0e0)
+		 (do ((m 10.0e0 (* m 10.0e0))
 		      (z y (* y m))
 		      (ex ex (1- ex)))
-		     ((>= z 0.1l0)
-		      (values (float z original-x) ex))))))))))
+		     ((>= z 0.1e0)
+		      (values (float z original-x) ex))
+                   (declare (long-float m) (integer ex))))
+              (declare (long-float d))))))))
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))
 
 ;;;; entry point for the float printer
 
@@ -1517,9 +1528,10 @@
 ;;; the character name or the character in the #\char format.
 (defun output-character (char stream)
   (if (or *print-escape* *print-readably*)
-      (let ((name (char-name char)))
+      (let ((graphicp (graphic-char-p char))
+	    (name (char-name char)))
 	(write-string "#\\" stream)
-	(if name
+	(if (and name (not graphicp))
 	    (quote-string name stream)
 	    (write-char char stream)))
       (write-char char stream)))