[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: floating point and other comments



On Mon, Dec 22, 2003 at 11:23:19PM -0600, Alex Shinn wrote:

> Ugh, no it wasn't, it was a very sloppy rip-off of my previous code
> which introduced several bugs.  The ~A fix was also broken.  I
> apologize for the poor code and attach a new version.

Attached for real this time.

-- 
Alex
;; IMPLEMENTATION DEPENDENT options

(define ascii-tab   (integer->char  9))  ;; Assume ASCII encoding
(define dont-print  (if (eq? #t #f) 1))  ;; Unspecified result
;;(define DONT-PRINT (string->symbol ""))
;;(define DONT-PRINT (void))
(define pretty-print display)  ;; Ugly, but permitted

;; FORMAT

(define (format . args)
  (cond
    ((null? args)
     (error "FORMAT: required format-string argument is missing")
     )
    ((string? (car args))
     (apply format (cons #f args)))
    ((< (length args) 2)
     (error (format #f "FORMAT: too few arguments ~a" (cons 'format args)))
     )
    (else
     (let ( (output-port   (car  args))
            (format-string (cadr args))
            (args          (cddr args))
            )
       (letrec ( (port
                  (cond ((output-port? output-port) output-port)
                        ((eq? output-port #t) (current-output-port))
                        ((eq? output-port #f) (open-output-string))
                        (else (error
                               (format #f "FORMAT: bad output-port argument: ~s"
                                       output-port)))
                        ))
                 (return-value
                  (if (eq? output-port #f)    ;; if format into a string
                    (lambda () (get-output-string port)) ;; then return the string
                    (lambda () dont-print)) ;; else do something harmless
                  )
                 )

         (define (round* n scale) ;; assume scale < 0
           (let ((one (expt 10 (- scale))))
             (/ (round (* n one)) one)))

         (define (string-index str c)
           (let ((len (string-length str)))
             (let loop ((i 0))
               (cond ((= i len) #f)
                     ((eqv? c (string-ref str i)) i)
                     (else (loop (+ i 1)))))))

         (define (string-grow str len char)
           (let ((off (- len (string-length str))))
             (if (positive? off)
               (string-append (make-string off char) str)
               str)))

         (define (string-pad-right str len char)
           (let ((slen (string-length str)))
             (cond ((< slen len)
                    (string-append str (make-string (- len slen) char)))
                   ((> slen len)
                    (substring str 0 len))
                   (else str))))

         (define (format-fixed num width digits)
           ((if width (lambda (s) (string-grow s width #\space))
                (lambda (s) s))
            (let ((real (real-part num))
                  (imag (imag-part num)))
              (cond
                ((not (zero? imag))
                 (string-append (format-fixed real #f digits)
                                (if (negative? imag) "" "+")
                                (format-fixed imag #f digits)
                                "i"))
                (digits
                 (let* ((n1 (exact->inexact (round* real (- digits))))
                        (s1 (number->string n1))
                        (d1 (string-index s1 #\.))
                        (s2 (if d1 s1 (string-append s1 ".0")))
                        (d2 (string-index s2 #\.))
                        (l2 (string-length s2))
                        (s3 (substring s2 (+ d2 1) l2)))
                   (string-append (substring s2 0 (+ d2 1))
                                  (string-pad-right s3 digits #\0))))
                (else (number->string num))))))

         (define (format-help format-strg arglist)

           (letrec (

                    (length-of-format-string (string-length format-strg))

                    (anychar-dispatch
                     (lambda (pos arglist last-was-newline)
                       (if (>= pos length-of-format-string)
                         arglist ; used for ~? continuance
                         (let ( (char (string-ref format-strg pos)) )
                           (cond
                             ((eq? char #\~)
                              (tilde-dispatch (+ pos 1) arglist '() '() last-was-newline))
                             (else
                              (write-char char port)
                              (anychar-dispatch (+ pos 1) arglist #f)
                              ))
                           ))
                       )) ; end anychar-dispatch

                    (collect-digits
                     (lambda (digits)
                       (and (pair? digits)
                            (string->number (list->string (reverse digits))))))

                    (tilde-dispatch
                     (lambda (pos arglist params digits last-was-newline)
                       (cond
                         ((>= pos length-of-format-string)
                          (write-char #\~ port) ; tilde at end of string is just output
                          arglist ; used for ~? continuance
                          )
                         (else
                          (case (char-upcase (string-ref format-strg pos))
                            ((#\A)       ; Any -- for humans
                             (let* ((x (car arglist))
                                    (nl? (if (string? x)
                                           (if (string=? x "") last-was-newline
                                               (eqv? #\newline (string-ref x (- (string-length x) 1))))
                                           (eqv? x #\newline))))
                               (display x port)
                               (anychar-dispatch (+ pos 1) (cdr arglist) nl?))
                             )
                            ((#\S)       ; Slashified -- for parsers
                             (write (car arglist) port)
                             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                             )
                            ((#\D)       ; Decimal
                             (display (number->string (car arglist) 10) port)
                             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                             )
                            ((#\X)       ; HeXadecimal
                             (display (number->string (car arglist) 16) port)
                             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                             )
                            ((#\O)       ; Octal
                             (display (number->string (car arglist)  8) port)
                             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                             )
                            ((#\B)       ; Binary
                             (display (number->string (car arglist)  2) port)
                             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                             )
                            ((#\C)       ; Character
                             (write-char (car arglist) port)
                             (anychar-dispatch (+ pos 1) (cdr arglist) (eq? (car arglist) #\newline))
                             )
                            ((#\P)       ; Plural
                             (if (<= (car arglist) 1)
                               #f ; no action
                               (write-char #\s port))
                             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                             )
                            ((#\~)       ; Tilde
                             (write-char #\~ port)
                             (anychar-dispatch (+ pos 1) arglist #f)
                             )
                            ((#\%)       ; Newline
                             (newline port)
                             (anychar-dispatch (+ pos 1) arglist #t)
                             )
                            ((#\&)      ; Freshline
                             (if (not last-was-newline) ;; (unless last-was-newline ..
                               (newline port))
                             (anychar-dispatch (+ pos 1) arglist #t)
                             )
                            ((#\_)       ; Space
                             (write-char #\space port)
                             (anychar-dispatch (+ pos 1) arglist #f)
                             )
                            ((#\T)       ; Tab -- IMPLEMENTATION DEPENDENT ENCODING
                             (write-char #\tab port)
                             (anychar-dispatch (+ pos 1) arglist #f)
                             )
                            ((#\Y)       ; Pretty-print
                             (pretty-print (car arglist) port)  ;; IMPLEMENTATION DEPENDENT
                             (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                             )
                            ;; {"~?" in Common Lisp is "~K" in T}
                            ((#\? #\K)       ; indirection -- take next arg as format string
                             (anychar-dispatch
                              (+ pos 1)
                              (format-help (car arglist) (cdr arglist)) ; Note: format-help returns unused args
                              #f)
                             )
                            ((#\F)
                             (let* ((plist (reverse (cons (collect-digits digits) params)))
                                    (width (and (pair? plist) (car plist)))
                                    (digits (and (pair? plist) (pair? (cdr plist)) (cadr plist))))
                               (display (format-fixed (car arglist) width digits) port)
                               (anychar-dispatch (+ pos 1) (cdr arglist) #f)))
                            ((#\,)
                             (tilde-dispatch (+ pos 1) arglist (cons (collect-digits digits) params)
                                             '() last-was-newline))
                            ((#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0 #\+ #\-)
                             (tilde-dispatch (+ pos 1) arglist params
                                             (cons (string-ref format-strg pos) digits)
                                             last-was-newline))
                            (else
                             (error (format "FORMAT: unknown tilde escape: ~a"
                                            (string-ref format-strg pos))))
                            )))
                       )) ; end tilde-dispatch
                    ) ; end letrec

                                        ; format-help main
             (anychar-dispatch 0 arglist #f)
             )) ; end format-help

                                        ; format main
         (format-help format-string args)
         (return-value)

         )) ; end letrec, if
     ))) ; end format