;;;  OpenMCL currently uses a non-readable #<> notation for
;;;  printing IEEE 754 infinity (INF) and negative infinity (-INF)
;;;  values.  We needed a readable, but non-evaluating, reader syntax for
;;;  infinite values.  Lispworks uses an extended number syntax with a doubled
;;;  exponent sign (with the second sign positive) to encode infinite values:
;;;      1e++0  positive infinity
;;;     -1e++0  negative infinity
;;;  Lispworks also uses a similar extension (but with a negative second 
;;;  exponent sign) to encode not-a-numbers (NaNs):
;;;      1e+-0  NaN
;;;  The sign of the first exponent sign (+ or -) doesn't matter in
;;;  determining the value (so 1e-+0 is also infinity and 1d--0 is also NaN).
;;;  The type of the value can be encoded just as with any other float
;;;  (1s++0, 1d++0, etc.).  We like the Lispworks encoding scheme and highly
;;;  recommend it become commonly used in other Common Lisp implementations.
;;;
;;;  The modifications below support this in OpenMCL.

(in-package :ccl)

;;; ---------------------------------------------------------------------------
;;; From lib/numbers.lisp

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant double-float-positive-infinity
      #.(unwind-protect
	    (progn
	      (set-fpu-mode :division-by-zero nil)
	      (/ 0d0))
	  (set-fpu-mode :division-by-zero t)))
  
  (defconstant double-float-negative-infinity
      #.(unwind-protect
	    (progn
	      (set-fpu-mode :division-by-zero nil)
	      (/ -0d0))
	  (set-fpu-mode :division-by-zero t))))
  
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant double-float-nan
      #.(unwind-protect
	    (progn
	      (set-fpu-mode :invalid nil)
	      (+ double-float-positive-infinity double-float-negative-infinity))
	  (set-fpu-mode :invalid t))))

(defun parse-float (str len off)  
  ; we cant assume this really is a float but dont call with eg s1 or e1
  (let ((integer 0)(expt 0)(sign 0)(done 0)(digits 0) point-pos type) 
    (setq integer
          (do ((n off (1+ n))
               (first t nil)
               (maxn  (+ off len)))
              ((>= n maxn) integer)
            (declare (fixnum n maxn))
            (let ((c (%schar str n)))
              (cond ((eq c #\.)
                     (setq point-pos digits))
                    ((and first (eq c #\+)))
                    ((and first (eq c #\-))
                     (setq sign -1))
                    ((memq c '(#\s #\f #\S #\F))
                     (setq type 'short-float)
                     (return integer))
                    ((memq c '(#\d #\l  #\D  #\L))
                     (setq type 'double-float)
                     (return integer))
                    ((memq c '(#\e #\E))
                     (return integer))
                    ((setq c (digit-char-p c))
                     (setq digits (1+ digits))
                     (setq integer (+ c (* 10 integer))))                  
                    (t (return-from parse-float nil)))
              (setq done (1+ done)))))
    (when point-pos
      (setq expt  (%i- point-pos digits)))
    (when (null type)
      (setq type *read-default-float-format*))
    (when (> len done)
      (let ((eexp nil) (inf nil) (nan nil) (esign 1) c (xsign-n -1))
        (do ((n (%i+ off done 1) (1+ n))
             (first t nil))
            ((>= n (+ off len)))
          (declare (fixnum n))
          (setq c (%schar str n))
          (cond ((and first (or (eq c #\+)(eq c #\-)))
                 (when (eq c #\-)(setq esign -1))
		 (setq xsign-n (1+ n)))
		((and (= n xsign-n)
		      (or (eq c #\+)(eq c #\-)))
                 (if (eq c #\-)
		     (setq nan t)
		     (setq inf t)))
                ((setq c (digit-char-p c))
                 (setq eexp (+ c (* (or eexp 0) 10))))
                (t (return-from parse-float nil))))
        (cond 
	 (inf 
	  (return-from parse-float
	    (coerce (if (minusp sign)
			double-float-negative-infinity
			double-float-positive-infinity)
		    type)))
	 (nan 
	  (return-from parse-float
	    (coerce double-float-nan type)))
	 (expt (setq expt (%i+ expt (* esign eexp))))
	 (t (return-from parse-float nil)))))
    ; if ppc read s as double vs error
    (fide sign integer expt (subtypep type 'short-float))))

;;; ---------------------------------------------------------------------------
;;; From level-1/l1-io.lisp:

#+ppc-target 
(defun print-a-nan (float stream)
  (if (infinity-p float)
      (output-float-infinity float stream)
      (output-float-nan float stream)))

#+ppc-target 
(defun output-float-infinity (x stream)
  (declare (float x) (stream stream))
  (format stream "~:[-~;~]1~c++0"
	  (plusp x)
	  (if (typep x *read-default-float-format*)
	      #\E
	      (typecase x
		(double-float #\D)
		(single-float #\S)))))

#+ppc-target 
(defun output-float-nan (x stream)
  (declare (float x) (stream stream))
  (format stream "1~c+-0 #| not-a-number |#"
	  (if (typep x *read-default-float-format*)
	      #\E
	      (etypecase x
		(double-float #\D)
		(single-float #\S)))))

;;; ---------------------------------------------------------------------------