;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: New FORMAT-EXP-AUX for CCL
;;   Created: 2020-05-27
;;    Author: Gilbert Baumann
;;   Version: 2
;; ---------------------------------------------------------------------------
;;  (c) copyright 2020 by Gilbert Baumann

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

(in-package :format)

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

(defun flonum-to-string* (n &optional nsig)
  ;; Sane version of FLONUM-TO-STRING.
  ;;
  ;; It returns two values: A string and and an exponent. Then:
  ;;
  ;;    (concatenate 'string "." string "E" (prin1-to-string exponent))
  ;;
  ;; is a representation of the number.
  ;;
  ;; When 'nsig' is given, it is the maximum number of significant digits to
  ;; produce.
  ;;
  (cond ((null nsig)
         (flonum-to-string n))
        (t
         (let ((scale (min 0 (scale-exponent n))))
           (multiple-value-bind (s e)
               (flonum-to-string n (1+ nsig) nil (- scale))
             (values s (+ e scale)))))))

(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
  ;;
  (when d
    (when (or (minusp d)
              (and (plusp k) (>= k (+ d 2)))
              (and (minusp k) (<= k (- d))))
      (format-error "incompatible values for k and d")))
  ;;
  (let ((old-nsig :unset)
        nsig exp-prn exp-str exp-len exp-est lzf room
        old-digits)
    ;;
    (tagbody
       (setq exp-est (scale-exponent number))
     again
       (setq exp-prn (if (zerop number) 0 (- exp-est k))
             exp-str (let ((*print-base* 10))
                       (princ-to-string (abs exp-prn)))
             exp-len (length exp-str)
             room    (and w (- w (+ 3 (max exp-len (or e 0))
                                    (if (or (minusp number) atsign) 1 0))))
             nsig    (or (and d    (+ d (min 1 k)))
                         (and room (max 1 (+ room (max 0 k))))))
       ;;
       (multiple-value-bind (digits exp)
           (if (eql old-nsig nsig)
               (values old-digits exp-est)
               (flonum-to-string* number nsig))
         ;;
         (unless (= exp exp-est)
           (setq exp-est exp
                 old-digits digits
                 old-nsig nsig)
           (go again))
         ;;
         (let* ((ndigits (length digits))
                (nprn (if d nsig (max (1+ k) ndigits))))
           (declare (type fixnum ndigits nprn k))
           ;; Corner case: When d=NIL and k<0 and we have no digits, print
           ;; exactly one zero. This is open for debate as the spec really
           ;; contradicts itself here.
           (when (and (null d) (< k 0) (= ndigits 0))
             (setq k -1))
           ;; Padding
           (when room
             (decf room nprn)
             (when (<= k 0)
               (decf room (- k))
               (when (> room 0)
                 (setq lzf t)
                 (decf room)))
             (when (and ovf (< room 0))
               (dotimes (i w) (write-char ovf stream))
               (go done))
             (dotimes (i room) (write-char pad stream)))
           ;; Sign
           (cond ((minusp number) (write-char #\- stream))
                 (atsign          (write-char #\+ stream)))
           ;; Digits
           (when (<= k 0)
             (when (or (null room) lzf) (write-char #\0 stream)))
           (when (< k 0)
             (write-char #\. stream)
             (dotimes (i (- k)) (write-char #\0 stream)))
           (dotimes (i nprn)
             (declare (type fixnum i))
             (when (= i k) (write-char #\. stream))
             (write-char (if (< i ndigits) (char digits i) #\0) stream))
           (when (= nprn 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 exp-len)) (write-char #\0 stream)))
           (stream-write-entire-string stream exp-str)))
     done
       )))