src/overload/format.lisp

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