Import Upstream version 2a6upstream/2a6

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)