Changeset 8236


Ignore:
Timestamp:
Jan 23, 2008, 2:08:13 AM (12 years ago)
Author:
gb
Message:

Daniel Dickinson's patch to ticket:230 (format ~F).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/1.1/ccl/lib/format.lisp

    r7777 r8236  
    17971797            (format-write-field stream (princ-to-string number) w 1 0 #\space t)))))))
    17981798
    1799 ; do something ad hoc if d > w - happens if (format nil "~15g" (- 2.3 .1))
    1800 ; called with w = 11 d = 16 - dont do it after all.
     1799;;; do something ad hoc if d > w - happens if (format nil "~15g" (- 2.3 .1))
     1800;;; called with w = 11 d = 16 - dont do it after all.
     1801
     1802(defvar format-digits-limit 100)
    18011803
    18021804(defun format-fixed-aux (stream number w d k ovf pad atsign)
    1803   (and w (<= w 0) (setq w nil))  ; if width is unreasonable, ignore it.
    1804   (if (not (or w d))  ; perhaps put this back when prin1 is better
    1805     (prin1 number stream)
    1806     (let ((spaceleft w)
    1807           (abs-number (abs number))
    1808           strlen zsuppress flonum-to-string-width)
    1809       (when (and w (or atsign (minusp number)))
    1810         (decf spaceleft))
    1811       (when (and d w (<= w (+ 1 d (if atsign 1 0))))
    1812         (setq zsuppress t))
    1813       (when (and d (minusp d))
    1814           (format-error "Illegal value for d"))
    1815       (setq flonum-to-string-width
    1816             (and w
    1817                  (if (and (< abs-number 1) (not zsuppress))
    1818                    (1- spaceleft)   ; room for leading 0
    1819                    spaceleft)))
    1820       (when (and w (not (plusp flonum-to-string-width)))
    1821         (if ovf
    1822           (progn
    1823             (dotimes (i w) (write-char ovf stream))
    1824             (return-from format-fixed-aux))
    1825           (setq spaceleft nil w nil)))
    1826       (multiple-value-bind (str before-pt after-pt)
    1827                            (flonum-to-string abs-number
    1828                                              flonum-to-string-width
    1829                                              d k)
    1830         (setq strlen (length str))
    1831         (cond (w (decf spaceleft (+ (max before-pt 0) 1))
    1832                  (when (and (< before-pt 1) (not zsuppress))
    1833                    (decf spaceleft))
    1834                  (if d
    1835                    (decf spaceleft d)
    1836                    (setq d (max (min spaceleft (- after-pt))
    1837                                 (if (> spaceleft 0) 1 0))
    1838                          spaceleft (- spaceleft d))))
    1839               ((null d) (setq d (max (- after-pt) 1))))
    1840         (cond ((and w (< spaceleft 0) ovf)
    1841                ;;field width overflow
    1842                (dotimes (i w) (declare (fixnum i)) (write-char ovf stream)))
    1843               (t (when w (dotimes (i spaceleft) (declare (fixnum i)) (write-char pad stream)))
    1844                  (if (minusp (float-sign number)) ; 5/25
    1845                    (write-char #\- stream)
    1846                    (if atsign (write-char #\+ stream)))
    1847                  (cond
    1848                   ((> before-pt 0)
    1849                    (cond ((> strlen before-pt)
    1850                           (write-string str stream :start  0 :end before-pt)
    1851                           (write-char #\. stream)
    1852                           (write-string str stream :start  before-pt :end strlen)
    1853                           (dotimes (i (- d (- strlen before-pt)))
    1854                             (write-char #\0 stream)))
    1855                          (t ; 0's after
    1856                           (stream-write-entire-string stream str)
    1857                           (dotimes (i (-  before-pt strlen))
    1858                             (write-char #\0 stream))
    1859                           (write-char #\. stream)
    1860                           (dotimes (i d)
    1861                             (write-char #\0 stream)))))
    1862                   (t (unless zsuppress (write-char #\0 stream))
    1863                      (write-char #\. stream)
    1864                      (dotimes (i (- before-pt)) 
    1865                        (write-char #\0 stream))
    1866                      (stream-write-entire-string stream str)
    1867                      (dotimes (i (+ d after-pt))
    1868                       (write-char #\0 stream))))))))))
     1805  (and w (<= w 0) (setq w nil))         ; if width is unreasonable, ignore it.
     1806  (let ((spaceleft w)
     1807        (abs-number (abs number))
     1808        strlen zsuppress flonum-to-string-width)
     1809    (when (and w (or atsign (minusp number)))
     1810      (decf spaceleft))
     1811    (when (and d w (<= w (+ 1 d (if atsign 1 0))))
     1812      (setq zsuppress t))
     1813    (when (and d (minusp d))
     1814      (format-error "Illegal value for d"))
     1815    (setq flonum-to-string-width
     1816          (and w
     1817               (if (and (< abs-number 1) (not zsuppress))
     1818                 (1- spaceleft)         ; room for leading 0
     1819                 spaceleft)))
     1820    (when (and w (not (plusp flonum-to-string-width)))
     1821      (if ovf
     1822        (progn
     1823          (dotimes (i w) (write-char ovf stream))
     1824          (return-from format-fixed-aux))
     1825        (setq spaceleft nil w nil)))
     1826    (multiple-value-bind (str before-pt after-pt)
     1827        (flonum-to-string abs-number
     1828                          flonum-to-string-width
     1829                          d k)
     1830      (setq strlen (length str))
     1831           (cond 
     1832             ((and (not (or w d)) (> (max (abs before-pt )(abs after-pt)) format-digits-limit))
     1833              (prin1 number stream))
     1834             (t
     1835              (cond (w (decf spaceleft (+ (max before-pt 0) 1))
     1836                       (when (and (< before-pt 1) (not zsuppress))
     1837                         (decf spaceleft))
     1838                       (if d
     1839                         (decf spaceleft d)
     1840                         (setq d (max (min spaceleft (- after-pt))
     1841                                      (if (> spaceleft 0) 1 0))
     1842                               spaceleft (- spaceleft d))))
     1843                    ((null d) (setq d (max (- after-pt) 1))))
     1844              (cond ((and w (< spaceleft 0) ovf)
     1845                     ;;field width overflow
     1846                     (dotimes (i w) (declare (fixnum i)) (write-char ovf stream)))
     1847                    (t (when w (dotimes (i spaceleft) (declare (fixnum i)) (write-char pad stream)))
     1848                       (if (minusp (float-sign number)) ; 5/25
     1849                         (write-char #\- stream)
     1850                         (if atsign (write-char #\+ stream)))
     1851                       (cond
     1852                         ((> before-pt 0)
     1853                          (cond ((> strlen before-pt)
     1854                                 (write-string str stream :start  0 :end before-pt)
     1855                                 (write-char #\. stream)
     1856                                 (write-string str stream :start  before-pt :end strlen)
     1857                                 (dotimes (i (- d (- strlen before-pt)))
     1858                                   (write-char #\0 stream)))
     1859                                (t              ; 0's after
     1860                                 (stream-write-entire-string stream str)
     1861                                 (dotimes (i (-  before-pt strlen))
     1862                                   (write-char #\0 stream))
     1863                                 (write-char #\. stream)
     1864                                 (dotimes (i d)
     1865                                   (write-char #\0 stream)))))
     1866                         (t (unless zsuppress (write-char #\0 stream))
     1867                            (write-char #\. stream)
     1868                            (dotimes (i (- before-pt))   
     1869                              (write-char #\0 stream))
     1870                            (stream-write-entire-string stream str)
     1871                            (dotimes (i (+ d after-pt))
     1872                              (write-char #\0 stream)))))))))))
    18691873#|
    18701874; (format t "~7,3,-2f" 8.88)
Note: See TracChangeset for help on using the changeset viewer.