src/overload/format.lisp

   1
   2 (defgeneric over-format (a strm))
   3
   4 (defmethod over-format ((n float) s)
   5   (let ((sig-figs 9);*sig-figs*)
   6         (mag 0)
   7         (neg (when (minusp n)
   8                (setq n (- n)) t)))
   9     (cond
  10       ((zerop n))
  11       ((< n 1d0)
  12        (loop :do (decf mag)
  13              :while (< (setq n (* n 10)) 1)))
  14       ((< n 10d0))
  15       (t (loop :do (incf mag)
  16                :until (< (setq n (/ n 10)) 10))))
  17     (princ (/ (round (* (if neg (- n) n)
  18                         (expt 10 sig-figs)))
  19               (expt 10d0 (- sig-figs mag)))
  20            s)))
  21
  22 (defmethod over-format ((a number) s)
  23   (princ a s))
  24 (defmethod over-format ((a cons) s)
  25   (output-tuple a s))
  26 (defmethod over-format ((a tuple) s)
  27   (output-tuple (tuple-elems a) s))
  28 (defmethod over-format ((a mtrix) s)
  29   (output-matrix (mtrix-elems a) s))
  30
  31 (defmethod over-format ((a string) strm)
  32   (princ a strm)
  33   (fresh-line strm))
  34