Skip to content

Commit

Permalink
Portably read float and complex literals without special syntax.
Browse files Browse the repository at this point in the history 
* Instead of using a special $ character, just portably modify the XC
readtable to do the right thing for floats by installing reader macros
for every possible initial character for a float. Special care needs
to be taken for #\., since consing dot needs to work. As of the time
of this commit, CCL, ECL, and CLISP break without installing a left
parenthesis macro that can also communicate with our new dot reader
macro, while SBCL and CMU CL do just fine without the additional new
left parenthesis character macro. It's unclear to me which behavior is
correct, and it may be the case that the standard is underspecified in
the situation where a reader macro is installed for dot and then
someone tries to read in a dotted list. In any case, installing a left
parenthesis reader macro for everybody is a portable solution that is
guaranteed to work everywhere.

* Also just install a reader macro for #c which constructs target
complex numbers instead of writing out the constant construction
manually.

* This avoids the big hack where we intercepted reading normal number
syntax in the reader only for specific versions of SBCL to catch float
and complex literals written the normal way and flame. Now we can make
sure host float and complex number literals never show up during the
build when bootstrapping from *any* host Lisp, by never allowing host
float and complex literals to be read in in the first place.

* This change uncovered a bug in CCL, whereby it was no longer able to
read #:-cache correctly. I've filed a bug for this here
Clozure/ccl#489 and worked around the issue
by just replacing it with its string name, since it was only used as
an argument for SYMBOLICATE.

* ECL also needs some help with the radix readers. See comment for bug
report.
  • Loading branch information
@karlosz
karlosz committed May 12, 2024
1 parent aed725f commit 6b09126
Show file tree
Hide file tree
Showing 44 changed files with 558 additions and 518 deletions.
17 changes: 7 additions & 10 deletions src/code/class.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1063,18 +1063,18 @@ between the ~A definition and the ~A definition"
:translation (complex single-float)
:inherits (complex number)
:codes (,sb-vm:complex-single-float-widetag)
:prototype-form ,(complex $0f0 $0f0))
:prototype-form ,(complex 0f0 0f0))
(complex-double-float
:translation (complex double-float)
:inherits (complex number)
:codes (,sb-vm:complex-double-float-widetag)
:prototype-form ,(complex $0d0 $0d0))
:prototype-form ,(complex 0d0 0d0))
#+long-float
(complex-long-float
:translation (complex long-float)
:inherits (complex number)
:codes (,sb-vm:complex-long-float-widetag)
:prototype-form ,(complex $0L0 $0L0))
:prototype-form ,(complex 0L0 0L0))
#+sb-simd-pack
(simd-pack
:translation simd-pack
Expand All @@ -1089,23 +1089,23 @@ between the ~A definition and the ~A definition"
;; (%make-simd-pack-256-ub64 42 42 42 42)
sb-pcl:+slot-unbound+)
(real :translation real :inherits (number) :prototype-form 0)
(float :translation float :inherits (real number) :prototype-form $0f0)
(float :translation float :inherits (real number) :prototype-form 0f0)
(single-float
:translation single-float
:inherits (float real number)
:codes (,sb-vm:single-float-widetag)
:prototype-form $0f0)
:prototype-form 0f0)
(double-float
:translation double-float
:inherits (float real number)
:codes (,sb-vm:double-float-widetag)
:prototype-form $0d0)
:prototype-form 0d0)
#+long-float
(long-float
:translation long-float
:inherits (float real number)
:codes (,sb-vm:long-float-widetag)
:prototype-form $0L0)
:prototype-form 0L0)
(rational
:translation rational :inherits (real number) :prototype-form 0)
(ratio
Expand Down Expand Up @@ -1307,14 +1307,11 @@ between the ~A definition and the ~A definition"
(list* name :predicate predicate :translation translation (cdr x))))
*builtin-classoids*)))

;;; The read interceptor has to be disabled to avoid infinite recursion on CTYPEs
(eval-when (:compile-toplevel) (setq sb-cold::*choke-on-host-irrationals* nil))
#-sb-xc-host
(define-load-time-global *builtin-classoids* nil)
#-sb-xc-host
(!cold-init-forms
(setq *builtin-classoids* '#.(compute-builtin-classoids)))
(eval-when (:compile-toplevel) (setq sb-cold::*choke-on-host-irrationals* t))

;;; See also src/code/type-init.lisp where we finish setting up the
;;; translations for built-in types.
Expand Down
11 changes: 10 additions & 1 deletion src/code/cross-early.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -112,7 +112,7 @@
(imag nil :type real :read-only t))

(defmethod print-object ((obj complexnum) stream)
(write-string "#.(COMPLEX " stream)
(write-string "#C( " stream)
(prin1 (complexnum-real obj) stream)
(write-char #\Space stream)
(prin1 (complexnum-imag obj) stream)
Expand All @@ -122,6 +122,15 @@
(declare (ignore env))
`(complex ,(complexnum-real obj) ,(complexnum-imag obj)))

;;; KLUDGE: this is more-or-less copied from sharpm,
(defun sb-cold::read-target-complex (stream sub-char numarg)
(declare (ignore sub-char numarg))
(let ((cnum (read stream t nil t)))
(when *read-suppress* (return-from sb-cold::read-target-complex nil))
(if (and (listp cnum) (= (length cnum) 2))
(complex (car cnum) (cadr cnum))
(error "illegal complex number format: #C~S" cnum))))

(defvar *interned-complex-numbers* (make-hash-table :test #'equal))

;;; REAL and IMAG are either host integers (therefore EQL-comparable)
Expand Down
109 changes: 48 additions & 61 deletions src/code/cross-float-reader.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -45,8 +45,6 @@
(single-float (%single-float-rational rational))
(double-float (%double-float-rational rational))))

(defvar *floating-point-number-buffer* (make-array 100 :element-type 'character))

(defun parse-xfloat-math-file (stream table)
;; Ensure that we're reading the correct variant of the file
;; in case there is more than one set of floating-point formats.
Expand Down Expand Up @@ -120,62 +118,51 @@
(values-list answer)
(multiple-value-call #'record-math-op fun args (progn ,@calculation))))))

(defun sb-cold::read-target-float (stream char)
(let ((buffer *floating-point-number-buffer*)
(index -1)
string)
(loop (setq char (read-char stream))
(cond ((or (digit-char-p char)
(member char '(#\+ #\- #\. #\D #\E #\F #\L #\S) :test #'char-equal))
(setf (aref buffer (incf index)) char))
(t
(unread-char char stream)
(return))))
(when *read-suppress*
(return-from sb-cold::read-target-float nil))
(setf string (subseq buffer 0 (1+ index)))
(multiple-value-bind (flonum nchars)
(with-memoized-math-op (read-from-string (list *read-default-float-format* string))
(let* ((marker-pos
(position-if (lambda (x)
(member x '(#\E #\S #\F #\D #\L) :test #'char-equal))
string))
(exp-marker (if (and marker-pos
(char-not-equal (char string marker-pos) #\E))
(char-upcase (char string marker-pos))
(ecase cl:*read-default-float-format*
((cl:single-float cl:short-float) #\F)
((cl:double-float cl:long-float) #\D))))
(significand (if marker-pos (subseq string 0 marker-pos) string))
(dot-pos (position #\. significand))
(integer (if (eql dot-pos 0) 0 (parse-integer significand :start 0 :end dot-pos)))
(fraction (if (and dot-pos (cl:> (length significand) (1+ dot-pos)))
(cl:/ (parse-integer significand :start (1+ dot-pos))
(cl:expt 10 (cl:- (length significand) (1+ dot-pos))))
0))
(exponent (if marker-pos
(parse-integer string :start (1+ marker-pos))
0))
(rational (cl:* (if (char= (char string 0) #\-)
(cl:- integer fraction)
(cl:+ integer fraction))
(cl:expt 10 exponent)))
(format (ecase exp-marker
((#\F #\S) 'single-float)
((#\D #\L) 'double-float))))
;; Since we are working with rationals, we must special-case
;; negative zero (which does not have a natural rational
;; representation: explicitly look for -0 string.
(if (or (string= significand "-0.0")
(string= significand "-.0")
(and (or (string= significand "-0") (string= significand "-0."))
(or marker-pos (error "~S has integer syntax" string))))
(ecase format
(single-float (values #.(make-single-float (ash -1 31))
(length string)))
(double-float (values #.(%make-double-float (ash -1 63))
(length string))))
(let ((result (flonum-from-rational rational format)))
(values result (length string))))))
(declare (ignore nchars))
flonum)))
(defun sb-cold::read-target-float-from-string (string)
(when *read-suppress*
(return-from sb-cold::read-target-float-from-string nil))
(multiple-value-bind (flonum nchars)
(with-memoized-math-op (read-from-string (list *read-default-float-format* (copy-seq string)))
(let* ((marker-pos
(position-if (lambda (x)
(member x '(#\E #\S #\F #\D #\L) :test #'char-equal))
string))
(exp-marker (if (and marker-pos
(char-not-equal (char string marker-pos) #\E))
(char-upcase (char string marker-pos))
(ecase cl:*read-default-float-format*
((cl:single-float cl:short-float) #\F)
((cl:double-float cl:long-float) #\D))))
(significand (if marker-pos (subseq string 0 marker-pos) string))
(dot-pos (position #\. significand))
(integer (if (eql dot-pos 0) 0 (parse-integer significand :start 0 :end dot-pos)))
(fraction (if (and dot-pos (cl:> (length significand) (1+ dot-pos)))
(cl:/ (parse-integer significand :start (1+ dot-pos))
(cl:expt 10 (cl:- (length significand) (1+ dot-pos))))
0))
(exponent (if marker-pos
(parse-integer string :start (1+ marker-pos))
0))
(rational (cl:* (if (char= (char string 0) #\-)
(cl:- integer fraction)
(cl:+ integer fraction))
(cl:expt 10 exponent)))
(format (ecase exp-marker
((#\F #\S) 'single-float)
((#\D #\L) 'double-float))))
;; Since we are working with rationals, we must special-case
;; negative zero (which does not have a natural rational
;; representation: explicitly look for -0 string.
(if (or (string= significand "-0.0")
(string= significand "-.0")
(and (or (string= significand "-0") (string= significand "-0."))
(or marker-pos (error "~S has integer syntax" string))))
(ecase format
(single-float (values #.(make-single-float (ash -1 31))
(length string)))
(double-float (values #.(%make-double-float (ash -1 63))
(length string))))
(let ((result (flonum-from-rational rational format)))
(values result (length string))))))
(declare (ignore nchars))
flonum))
Loading

0 comments on commit 6b09126

Please sign in to comment.