#!+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-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"
+ *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-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"
`(%with-standard-io-syntax (lambda () ,@body)))
(defun %with-standard-io-syntax (function)
#!+sb-doc
"Output a mostly READable printed representation of OBJECT on the specified
STREAM."
- (let ((*print-escape* T))
+ (let ((*print-escape* t))
(output-object object (out-synonym-of stream)))
object)
#!+sb-doc
"Output an aesthetic but not necessarily READable printed representation
of OBJECT on the specified STREAM."
- (let ((*print-escape* NIL)
- (*print-readably* NIL))
+ (let ((*print-escape* nil)
+ (*print-readably* nil))
(output-object object (out-synonym-of stream)))
object)
#!+sb-doc
"Return the printed representation of OBJECT as a string with
slashification on."
- (stringify-object object t))
+ (let ((*print-escape* t))
+ (stringify-object object)))
(defun princ-to-string (object)
#!+sb-doc
"Return the printed representation of OBJECT as a string with
slashification off."
- (stringify-object object nil))
+ (let ((*print-escape* nil)
+ (*print-readably* nil))
+ (stringify-object object)))
;;; 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 &optional (*print-escape* *print-escape*))
+(defun stringify-object (object)
(let ((stream (if *string-output-streams*
(pop *string-output-streams*)
(make-string-output-stream))))
;; Someone forgot to initiate circularity detection.
(let ((*print-circle* nil))
(error "trying to use CHECK-FOR-CIRCULARITY when ~
- circularity checking isn't initiated")))
+ 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.
;;; character has. At characters have at least one bit set, so we can
;;; search for any character with a positive test.
(defvar *character-attributes*
- (make-array char-code-limit
+ (make-array 160 ; FIXME
:element-type '(unsigned-byte 16)
:initial-element 0))
-(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 16) (#.160)) ; FIXME
*character-attributes*))
;;; constants which are a bit-mask for each interesting character attribute
(set-bit #\/ slash-attribute)
;; Mark anything not explicitly allowed as funny.
- (dotimes (i char-code-limit)
+ (dotimes (i 160) ; FIXME
(when (zerop (aref *character-attributes* i))
(setf (aref *character-attributes* i) funny-attribute))))
;;; For each character, the value of the corresponding element is the
;;; lowest base in which that character is a digit.
(defvar *digit-bases*
- (make-array char-code-limit
+ (make-array 128 ; FIXME
:element-type '(unsigned-byte 8)
:initial-element 36))
-(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+(declaim (type (simple-array (unsigned-byte 8) (#.128)) ; FIXME
*digit-bases*))
(dotimes (i 36)
(let ((char (digit-char i 36)))
,(if at-end '(go TEST-SIGN) '(return nil)))
(setq current (schar name index)
code (char-code current)
- bits (aref attributes code))
+ bits (cond ; FIXME
+ ((< code 160) (aref attributes code))
+ ((upper-case-p current) uppercase-attribute)
+ ((lower-case-p current) lowercase-attribute)
+ (t other-attribute)))
(incf index)
(go ,tag)))
(test (&rest attributes)
attributes))
bits)))))
(digitp ()
- `(< (the fixnum (aref bases code)) base)))
+ `(and (< code 128) ; FIXME
+ (< (the fixnum (aref bases code)) base))))
(prog ((len (length name))
(attributes *character-attributes*)
letter-attribute)))
(do ((i (1- index) (1+ i)))
((= i len) (return-from symbol-quotep nil))
- (unless (zerop (logand (aref attributes (char-code (schar name i)))
+ (unless (zerop (logand (let* ((char (schar name i))
+ (code (char-code char)))
+ (cond
+ ((< code 160) (aref attributes code))
+ ((upper-case-p char) uppercase-attribute)
+ ((lower-case-p char) lowercase-attribute)
+ (t other-attribute)))
mask))
(return-from symbol-quotep t))))
projects / sbcl.git / blobdiff