summaryrefslogtreecommitdiffstats
path: root/printf.scm
diff options
context:
space:
mode:
Diffstat (limited to 'printf.scm')
-rw-r--r--printf.scm278
1 files changed, 278 insertions, 0 deletions
diff --git a/printf.scm b/printf.scm
new file mode 100644
index 0000000..dffe90d
--- /dev/null
+++ b/printf.scm
@@ -0,0 +1,278 @@
+;;;; "printf.scm" Implementation of standard C functions for Scheme
+;;; Copyright (C) 1991-1993, 1996 Aubrey Jaffer.
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'string-case)
+
+;;; Floating point is not handled yet.
+
+(define (stdio:iprintf out-proc format-string . args)
+ (define char-count 0)
+ (define (out c)
+ (cond ((char? c) (set! char-count (+ 1 char-count)))
+ (else (set! char-count (+ (string-length c) char-count))))
+ (out-proc c) #t)
+ (cond
+ ((not (equal? "" format-string))
+ (let ((pos -1)
+ (fl (string-length format-string))
+ (fc (string-ref format-string 0)))
+
+ (define (advance)
+ (set! pos (+ 1 pos))
+ (cond ((>= pos fl) (set! fc #f))
+ (else (set! fc (string-ref format-string pos)))))
+ (define (must-advance)
+ (set! pos (+ 1 pos))
+ (cond ((>= pos fl) (incomplete))
+ (else (set! fc (string-ref format-string pos)))))
+ (define (end-of-format?)
+ (>= pos fl))
+ (define (incomplete)
+ (slib:error 'printf "conversion specification incomplete"
+ format-string))
+
+ (let loop ((args args))
+ (advance)
+ (cond
+ ((end-of-format?))
+ ((eqv? #\\ fc);;Emulating C strings may not be a good idea.
+ (must-advance)
+ (case fc
+ ((#\n #\N) (out #\newline))
+ ((#\t #\T) (out slib:tab))
+ ((#\r #\R) (out #\return))
+ ((#\f #\F) (out slib:form-feed))
+ ((#\newline) #f)
+ (else (out fc)))
+ (loop args))
+ ((eqv? #\% fc)
+ (must-advance)
+ (let ((left-adjust #f) ;-
+ (signed #f) ;+
+ (blank #f)
+ (alternate-form #f) ;#
+ (leading-0s #f) ;0
+ (width 0)
+ (precision -1)
+ (type-modifier #f)
+ (read-format-number
+ (lambda ()
+ (cond
+ ((eqv? #\* fc) ; GNU extension
+ (must-advance)
+ (let ((ans (car args)))
+ (set! args (cdr args))
+ ans))
+ (else
+ (do ((c fc fc)
+ (accum 0 (+ (* accum 10)
+ (string->number (string c)))))
+ ((not (char-numeric? fc)) accum)
+ (must-advance)))))))
+ (define integer-pad
+ (lambda (s radix)
+ (cond ((not (negative? precision))
+ (set! leading-0s #f)))
+ (let* ((pre
+ (cond ((equal? "" s) "")
+ ((eqv? #\- (string-ref s 0))
+ (set! s (substring s 1 (string-length s)))
+ "-")
+ (signed "+")
+ (blank " ")
+ ((equal? "" s) "")
+ (alternate-form
+ (case radix
+ ((8) "0")
+ ((16) "0x")
+ (else "")))
+ (else "")))
+ (length-so-far (+ (string-length pre)
+ (string-length s))))
+ (cond ((<= width length-so-far)
+ (string-append pre s))
+ (left-adjust
+ (string-append
+ pre s
+ (make-string (- width length-so-far) #\ )))
+ (leading-0s
+ (string-append
+ pre (make-string (- width length-so-far) #\0)
+ s))
+ (else
+ (string-append
+ (make-string (- width length-so-far) #\ )
+ pre s))))))
+
+ (do ()
+ ((case fc
+ ((#\-) (set! left-adjust #t) #f)
+ ((#\+) (set! signed #t) #f)
+ ((#\ ) (set! blank #t) #f)
+ ((#\#) (set! alternate-form #t) #f)
+ ((#\0) (set! leading-0s #t) #f)
+ (else #t)))
+ (must-advance))
+ (cond (left-adjust (set! leading-0s #f)))
+ (cond (signed (set! blank #f)))
+
+ (set! width (read-format-number))
+ (cond ((negative? width)
+ (set! left-adjust #t)
+ (set! width (- width))))
+ (cond ((eqv? #\. fc)
+ (must-advance)
+ (set! precision (read-format-number))))
+ (case fc ;Ignore these specifiers
+ ((#\l #\L #\h)
+ (set! type-modifier fc)
+ (must-advance)))
+
+ (case fc
+ ;; only - is allowed between % and c
+ ((#\c #\C) ; C is enhancement
+ (out (string (car args)))
+ (loop (cdr args)))
+
+ ;; only - flag, no type-modifiers
+ ((#\s #\S) ; S is enhancement
+ (let ((s (cond
+ ((symbol? (car args)) (symbol->string (car args)))
+ ((not (car args)) "(NULL)")
+ (else (car args)))))
+ (cond ((not (or (negative? precision)
+ (>= precision (string-length s))))
+ (set! s (substring s 0 precision))))
+ (out
+ (cond
+ ((<= width (string-length s)) s)
+ (left-adjust
+ (string-append
+ s (make-string (- width (string-length s)) #\ )))
+ (else
+ (string-append (make-string (- width (string-length s))
+ (if leading-0s #\0 #\ )) s))))
+ (loop (cdr args))))
+
+ ;; SLIB extension
+ ((#\a #\A) ;#\y #\Y are pretty-print
+ (require 'generic-write)
+ (let ((os "") (pr precision))
+ (generic-write
+ (car args) (not alternate-form) #f
+ (cond ((and left-adjust (negative? pr))
+ out)
+ (left-adjust
+ (lambda (s)
+ (define sl (- pr (string-length s)))
+ (set! pr (cond ((negative? sl)
+ (out (substring s 0 pr)) 0)
+ (else (out s) sl)))
+ (positive? sl)))
+ ((negative? pr)
+ (set! pr width)
+ (lambda (s)
+ (set! pr (- pr (string-length s)))
+ (cond ((not os) (out s))
+ ((negative? pr)
+ (out os)
+ (set! os #f)
+ (out s))
+ (else (set! os (string-append os s))))
+ #t))
+ (else
+ (lambda (s)
+ (define sl (- pr (string-length s)))
+ (cond ((negative? sl)
+ (set! os (string-append
+ os (substring s 0 pr))))
+ (else (set! os (string-append os s))))
+ (set! pr sl)
+ (positive? sl)))))
+ (cond (left-adjust
+ (cond
+ ((> width (- precision pr))
+ (out (make-string (- width (- precision pr))
+ #\ )))))
+ ((not os))
+ ((<= width (string-length os)) (out os))
+ (else
+ (out (make-string (- width (string-length os)) #\ ))
+ (out os))))
+ (loop (cdr args)))
+
+ ((#\d #\D #\i #\I #\u #\U)
+ (out (integer-pad
+ (cond ((symbol? (car args))
+ (symbol->string (car args)))
+ ((number? (car args))
+ (number->string (car args)))
+ ((not (car args)) "0")
+ (else "1"))
+ 10))
+ (loop (cdr args)))
+ ((#\o #\O)
+ (out (integer-pad (number->string (car args) 8) 8))
+ (loop (cdr args)))
+ ((#\x #\X)
+ (out
+ ((if (char-upper-case? fc) string-upcase string-downcase)
+ (integer-pad (number->string (car args) 16) 16)))
+ (loop (cdr args)))
+ ((#\%) (out #\%)
+ (loop args))
+ (else
+ (cond ((end-of-format?) (incomplete))
+ (else (out #\%) (out fc) (out #\?)
+ (loop args)))))))
+ (else (out fc)
+ (loop args)))))))
+ char-count) ; return number of characters output.
+
+(define (stdio:printf format . args)
+ (apply stdio:iprintf display format args))
+
+(define (stdio:fprintf port format . args)
+ (if (equal? port (current-output-port))
+ (apply stdio:iprintf display format args)
+ (apply stdio:iprintf (lambda (x) (display x port)) format args)))
+
+(define (stdio:sprintf s format . args)
+ (let ((p 0) (end (string-length s)))
+ (apply stdio:iprintf
+ (lambda (x)
+ (cond ((string? x)
+ (do ((i 0 (+ i 1)))
+ ((>= i (min (string-length x) end)))
+ (string-set! s p (string-ref x i))
+ (set! p (+ p 1))))
+ ((>= p end))
+ ((char? x)
+ (string-set! s p x)
+ (set! p (+ p 1)))
+ (else
+ (string-set! s p #\?)
+ (set! p (+ p 1)))))
+ format
+ args)
+ p))
+
+(define printf stdio:printf)
+(define fprintf stdio:fprintf)
+(define sprintf stdio:sprintf)