;;; WORK IN PROGRESS !!!!!!!!!!!!!!

;;; WORK IN PROGRESS !!!!!!!!!!!!!!

;;; WORK IN PROGRESS !!!!!!!!!!!!!!

(defpackage :format
  (:use :common-lisp :ccl)
  (:import-from :ccl
                #:scale-exponent
                #:flonum-to-string
                #:format-exponent-marker
                #:stream-write-entire-string
                #:format-exp-aux
                ;;
                #:%code-char
                #:%char-code
                #:%i+
                #:5-to-e
                #:10-to-e
                #:while
                ))

(in-package :format)

(setq ccl::*warn-if-redefine-kernel* nil)

(defun format-exp-aux (stream number w d e k ovf pad marker atsign &optional ignore-1 ignore-2)
  (declare (ignore ignore-1 ignore-2))
  (unless k (setq k 1))                 ;default
  (let (nsig exp-prn exp-str exp-est lzf (orig-w w))
    ;;
    (tagbody
       ;; Get an estimate of the exponet. When FLONUM-TO-STRING
       ;; tells us another exponent we do again via the label AGAIN
       ;; below.
       (setq exp-est (scale-exponent number))
     again
       (let ((w w))
         (setq exp-prn (if (zerop number) 0 (- exp-est k))
               exp-str (let ((*print-base* 10))
                         (princ-to-string (abs exp-prn))))
         ;;
         (when w
           ;; Deduce room for mandatory dot, exponent marker, exponent
           ;; sign.
           (decf w 3)
           ;; Room for optional sign
           (when (or (minusp number) atsign)
             (decf w 1))
           ;; Exponent itself
           (decf w (max (length exp-str) (or e 0))))
         ;;
         ;; Now 'w' is either NIL or the room left for the digits of the
         ;; mantissa (excluding the dot).
         ;;
         ;; Figure out number of significant digits to print.
         (setq nsig (cond ((not (null d))
                           (+ (max d (- k 1)) ;no negative number of digits
                                        ;after the dot
                              (min 1 k)))
                          ((not (null w))
                           (+ w (min 0 k)))))
         (when nsig (setq nsig (max 0 nsig)))
         ;;
         (multiple-value-bind (digits exp)
             (flonum-to-string number (and nsig (+ nsig (max 0 (- exp-prn)) 1)))
           (unless (= exp exp-est)
             ;; Our estimated exponent is wrong, do again with the
             ;; correct one.
             (setq exp-est exp)
             (go again))
           ;;
           (let ((ndigits (length digits)))
             ;;
             '(unless d
               (setq nsig
                     (if (zerop ndigits)
                         (max 2 (1+ k)) ;for the zero beyond the dot ### ???
                         (max k ndigits))))
             ;;
             (unless d
               ;; We need at leas k digts, in in case ndigits = k, we
               ;; need another, so that the fraction part is not
               ;; empty, which is what the spec says.
               (setq nsig
                     (max (1+ k) ndigits)))
             ;;
             ;; ### here is another corner case. When d, k, w, and e
             ;; ### [sic!] are ommitted, we need to have a digit on
             ;; ### either side of the dot:
             ;;
             (when (and (= k 1) (null d) (null w) (null e))
               (setq nsig (max 2 nsig)))
             ;;
             ;; Padding and watch for an optional zero before the dot in
             ;; the k<0 case. Set `lzf`, if allowed.
             ;;
             (when w
               (decf w nsig)
               (when (<= k 0)
                 (decf w (- k))
                 (when (> w 0)
                   (setq lzf t)
                   (decf w)))
               ;; ### overflow on 'e'?
               (when (and ovf (< w 0))
                 (dotimes (i orig-w)
                   (write-char ovf stream))
                 (return-from format-exp-aux)) ;all done
               ;;
               (dotimes (i w) (write-char pad stream)))
             ;; sign
             (cond ((minusp number)
                    (write-char #\- stream))
                   (atsign
                    (write-char #\+ stream)))
             ;;
             ;; Basically, we write 'k' digits from 'digits', a dot and then
             ;; the rest.
             ;;
             ;; What we miss: when d is not given: No trailing zeros! What
             ;; about leading zeros?
             ;;
             (when (<= k 0)
               (when (or (null w) lzf) (write-char #\0 stream)))
             (when (< k 0)
               (write-char #\. stream)
               (dotimes (i (- k)) (write-char #\0 stream)))
             ;;
             (dotimes (i nsig)
               (when (= i k) (write-char #\. stream))
               (write-char (if (< i ndigits) (char digits i) #\0) stream))
             (when (= nsig k) (write-char #\. stream))
             ;; Exponent
             (write-char (or marker (format-exponent-marker number)) stream)
             (write-char (if (minusp exp-prn) #\- #\+) stream)
             (when e (dotimes (i (- e (length exp-str))) (write-char #\0 stream)))
             (stream-write-entire-string stream exp-str)))))))