:test #'char= :key #'car)))
(set-cat-entry to-char att to-readtable)
(set-cmt-entry to-char mac to-readtable)
- (when from-dpair
- (cond
- (to-dpair
- (let ((table (cdr to-dpair)))
- (clrhash table)
- (shallow-replace/eql-hash-table table (cdr from-dpair))))
- (t
- (let ((pair (cons to-char (make-hash-table))))
- (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+ (cond ((and (not from-dpair) (not to-dpair)))
+ ((and (not from-dpair) to-dpair)
(setf (dispatch-tables to-readtable)
- (push pair (dispatch-tables to-readtable)))))))))
+ (remove to-dpair (dispatch-tables to-readtable))))
+ (to-dpair
+ (let ((table (cdr to-dpair)))
+ (clrhash table)
+ (shallow-replace/eql-hash-table table (cdr from-dpair))))
+ (t
+ (let ((pair (cons to-char (make-hash-table))))
+ (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+ (setf (dispatch-tables to-readtable)
+ (push pair (dispatch-tables to-readtable))))))))
t)
(defun set-macro-character (char function &optional
"Causes CHAR to be a macro character which invokes FUNCTION when seen
by the reader. The NON-TERMINATINGP flag can be used to make the macro
character non-terminating, i.e. embeddable in a symbol name."
- (let ((designated-readtable (or rt-designator *standard-readtable*)))
+ (let ((designated-readtable (or rt-designator *standard-readtable*))
+ (function (%coerce-callable-to-fun function)))
(assert-not-standard-readtable designated-readtable 'set-macro-character)
(set-cat-entry char (if non-terminatingp
+char-attr-constituent+
(cond (all-lower (raise-em))
(all-upper (lower-em))))))))))))
+(defvar *reader-package* nil)
+
(defun read-token (stream firstchar)
#!+sb-doc
- "This function is just an fsm that recognizes numbers and symbols."
+ "Default readmacro function. Handles numbers, symbols, and SBCL's
+extended <package-name>::<form-in-package> syntax."
;; Check explicitly whether FIRSTCHAR has an entry for
;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and
;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are
(case (char-class char attribute-array attribute-hash-table)
(#.+char-attr-delimiter+
(unread-char char stream)
- (simple-reader-error stream
- "illegal terminating character after a colon: ~S"
- char))
+ (if package-designator
+ (let* ((*reader-package* (%find-package-or-lose package-designator)))
+ (return (read stream t nil t)))
+ (simple-reader-error stream
+ "illegal terminating character after a double-colon: ~S"
+ char)))
(#.+char-attr-single-escape+ (go SINGLE-ESCAPE))
(#.+char-attr-multiple-escape+ (go MULT-ESCAPE))
(#.+char-attr-package-delimiter+
RETURN-SYMBOL
(casify-read-buffer escapes)
(let ((found (if package-designator
- (find-package package-designator)
- (sane-package))))
- (unless found
- (error 'simple-reader-package-error :stream stream
- :format-arguments (list package-designator)
- :format-control "package ~S not found"))
-
+ (or (find-package package-designator)
+ (error 'simple-reader-package-error
+ :package package-designator
+ :stream stream
+ :format-control "Package ~A does not exist."
+ :format-arguments (list package-designator)))
+ (or *reader-package* (sane-package)))))
(if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
(return (intern* *read-buffer* *ouch-ptr* found))
(multiple-value-bind (symbol test)
(when (eq test :external) (return symbol))
(let ((name (read-buffer-to-string)))
(with-simple-restart (continue "Use symbol anyway.")
- (error 'simple-reader-package-error :stream stream
+ (error 'simple-reader-package-error
+ :package found
+ :stream stream
:format-arguments (list name (package-name found))
:format-control
(if test
(the index (* num base))))))))
(setq number (+ num (* number base-power)))))))
+(defun truncate-exponent (exponent number divisor)
+ "Truncate exponent if it's too large for a float"
+ ;; Work with base-2 logarithms to avoid conversions to floats,
+ ;; and convert to base-10 conservatively at the end.
+ ;; Use the least positive float, because denormalized exponent
+ ;; can be larger than normalized.
+ (let* ((max-exponent
+ #!-long-float
+ (+ sb!vm:double-float-digits sb!vm:double-float-bias))
+ (number-magnitude (integer-length number))
+ (divisor-magnitude (1- (integer-length divisor)))
+ (magnitude (- number-magnitude divisor-magnitude)))
+ (if (minusp exponent)
+ (max exponent (ceiling (- (+ max-exponent magnitude))
+ #.(floor (log 10 2))))
+ (min exponent (floor (- max-exponent magnitude)
+ #.(floor (log 10 2)))))))
+
(defun make-float (stream)
;; Assume that the contents of *read-buffer* are a legal float, with nothing
;; else after it.
(#\F 'single-float)
(#\D 'double-float)
(#\L 'long-float)))
+ (exponent (truncate-exponent exponent number divisor))
(result (make-float-aux (* (expt 10 exponent) number)
divisor float-format stream)))
(return-from make-float
(type-error (c)
(error 'reader-impossible-number-error
:error c :stream stream
- :format-control "failed to build float"))))
+ :format-control "failed to build float from ~a"
+ :format-arguments (list (read-buffer-to-string))))))
(defun make-ratio (stream)
;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
projects / sbcl.git / blobdiff