share/numeric/forma1.lisp

   1 (declare (special $floatformat floatmax floatmin floatsmall
   2                   floatbig floatbigbig float-enote))
   3
   4
   5 (defmvar $floatformat t)
   6
   7 ;;; defaults
   8
   9 (defmvar floatmax 6)
  10 (defmvar floatmin -4)
  11 (defmvar floatbig 2)
  12 (defmvar floatbigbig 1)
  13 (defmvar floatsmall 3)
  14 (defmvar float-enote 2)
  15
  16 (putprop 'makestring1 (get 'makestring 'subr) 'subr)
  17
  18 (defun makestring (form)
  19        (cond ((and $floatformat (floatp form)) (nicefloat form))
  20              ((makestring1 form))))
  21
  22 (defun nicefloat (flt)
  23   (cond ((= flt 0.0) (list 48. 46. 48.))
  24         ((< flt 0.0) (cons 45. (niceflt (abs flt))))
  25         ((niceflt (abs flt)))))
  26
  27 (defun niceflt (aflt)
  28   (declare (fixnum i))
  29   (do ((i 0)
  30        (simflt aflt)
  31        (fac (cond ((< aflt 1.0) 1e1) (1e-1)))
  32        (inc (cond ((< aflt 1.0) -1) (1))))
  33       ((and (< simflt 1e1) (not (< simflt 1.0)))
  34        (floatcheck (exploden simflt) i))
  35     (setq simflt (* simflt fac))
  36     (incf i inc)))
  37
  38 (defun floatcheck (repres pwr)
  39     (declare (fixnum pwr))
  40     (cond
  41       ((or (> pwr (1- floatmax)) (< pwr floatmin))
  42        (cons (car repres)
  43              (cons 46.
  44                    (append (fracgen (cddr repres) float-enote nil)
  45                            (cons 69.(cond ((> pwr 0)
  46                                            (cons 43 (exploden pwr)))
  47                                           ((exploden pwr))))))))
  48       ((< pwr 0.)
  49        ((lambda (frac)
  50           (cons 48.
  51                 (cons 46.
  52                       (cond ((equal frac '(48.)) frac)
  53                             ((append (fraczeros (1- (abs pwr)))
  54                                      frac))))))
  55         (fracgen (delete 46. repres) floatsmall nil)))
  56       ((cons (car repres)
  57              (floatnone (cddr repres)
  58                         pwr
  59                         (cond ((< pwr 3.) floatbig)
  60                               (floatbigbig)))))))
  61
  62 (defun fraczeros (n)
  63        (declare (fixnum n))
  64        (cond ((zerop n) nil) ((cons 48. (fraczeros (1- n))))))
  65
  66 (defun floatnone (repres pwr floatfrac)
  67        (declare (fixnum pwr floatfrac))
  68        (cond ((zerop pwr) (cons 46. (fracgen repres floatfrac nil)))
  69              ((cons (cond (repres (car repres)) (48.))
  70                     (floatnone (cdr repres) (1- pwr) floatfrac)))))
  71
  72 (defun felimin (revrep)
  73        (cond ((null revrep) (ncons 48.))
  74              ((= (car revrep) 48.) (felimin (cdr revrep)))
  75              ((reverse revrep))))
  76
  77 (defun fracgen (repres floatfrac result)
  78        (declare (fixnum floatfrac))
  79        (cond ((null repres) (felimin result))
  80              ((zerop floatfrac) (felimin result))
  81              ((fracgen (cdr repres)
  82                        (1- floatfrac)
  83                        (cons (car repres) result)))))