printf.scm

A framework written in Java for implementing high-level and dynamic languages, compiling them into J

;;;; "printf.scm" Implementation of standard C functions for Scheme
;;; Copyright (C) 1991-1993, 1996, 1999-2001 Aubrey Jaffer and Radey Shouman.
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, 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)
(require 'generic-write)

;; Determine the case of digits > 9.  We assume this to be constant.
(define-constant stdio:hex-upper-case? :: <boolean>
  (string=? "-F" (number->string -15 16)))

;; Parse the output of NUMBER->STRING and pass the results to PROC.
;; PROC takes (SIGN-CHARACTER DIGIT-STRING EXPONENT-INTEGER . IMAGPART)
;; SIGN-CHAR will be either #\+ or #\-, DIGIT-STRING will always begin
;; with a "0", after which a decimal point should be understood.
;; If STR denotes a number with imaginary part not exactly zero,
;; 3 additional elements for the imaginary part are passed.
;; If STR cannot be parsed, return #F without calling PROC.
(define-constant (stdio:parse-float str proc)
  (let ((n (string-length str)))
    (define (parse-error) #f)
    (define (prefix i cont)
      (if (and (< i (- n 1))
	       (char=? #\# (string-ref str i)))
	  (case (string-ref str (+ i 1))
	    ((#\d #\i #\e) (prefix (+ i 2) cont))
	    ((#\.) (cont i))
	    (else (parse-error)))
	  (cont i)))
    (define (sign i cont)
      (if (< i n)
	  (let ((c (string-ref str i)))
	    (case c
	      ((#\- #\+) (cont (+ i 1) c))
	      (else (cont i #\+))))))
    (define (digits i cont)
      (do ((j i (+ j 1)))
	  ((or (>= j n)
	       (not (or (char-numeric? (string-ref str j))
			(char=? #\# (string-ref str j)))))
	   (cont j (if (= i j) "0" (substring str i j))))))
    (define (point i cont)
      (if (and (< i n)
	       (char=? #\. (string-ref str i)))
	  (cont (+ i 1))
	  (cont i)))
    (define (exp i cont)
      (cond ((>= i n) (cont i 0))
	    ((memv (string-ref str i)
		   '(#\e #\s #\f #\d #\l #\E #\S #\F #\D #\L))
	     (sign (+ i 1)
		   (lambda (i sgn)
		     (digits i
			     (lambda (i digs)
			       (cont i
				     (if (char=? #\- sgn)
					 (- (string->number digs))
					 (string->number digs))))))))
	    (else (cont i 0))))
    (define (real i cont)
      (prefix
       i
       (lambda (i)
	 (sign
	  i
	  (lambda (i sgn)
	    (digits
	     i
	     (lambda (i idigs)
	       (point
		i
		(lambda (i)
		  (digits
		   i
		   (lambda (i fdigs)
		     (exp i
			  (lambda (i ex)
			    (let* ((digs (string-append "0" idigs fdigs))
				   (ndigs (string-length digs)))
			      (let loop ((j 1)
					 (ex (+ ex (string-length idigs))))
				(cond ((>= j ndigs) ;; Zero
				       (cont i sgn "0" 1))
				      ((char=? #\0 (string-ref digs j))
				       (loop (+ j 1) (- ex 1)))
				      (else
				       (cont i sgn
					     (substring digs (- j 1) ndigs)
					     ex))))))))))))))))))
    (real 0
	  (lambda (i sgn digs ex)
	    (cond
	     ((= i n) (proc sgn digs ex))
	     ((memv (string-ref str i) '(#\+ #\-))
	      (real i
		    (lambda (j im-sgn im-digs im-ex)
		      (if (and (= j (- n 1))
			       (char-ci=? #\i (string-ref str j)))
			  (proc sgn digs ex im-sgn im-digs im-ex)
			  (parse-error)))))
	     ((eqv? (string-ref str i) #\@)
	      ;; Polar form: No point in parsing the angle ourselves,
	      ;; since some transcendental approximation is unavoidable.
	      (let ((num (string->number str)))
		(if num
		    (stdio:parse-float
		     (number->string (real-part num))
		     (lambda (sgn digs ex)
		       (stdio:parse-float
			(number->string (imag-part num))
			(lambda (im-sgn im-digs im-ex)
			  (proc sgn digs ex im-sgn im-digs im-ex)))))
		    (parse-error))))
	     (else #f))))))

;; STR is a digit string representing a floating point mantissa, STR must
;; begin with "0", after which a decimal point is understood.
;; The output is a digit string rounded to NDIGS digits after the decimal
;; point implied between chars 0 and 1.
;; If STRIP-0S is not #F then trailing zeros will be stripped from the result.
;; In this case, STRIP-0S should be the minimum number of digits required
;; after the implied decimal point.
(define-constant (stdio:round-string (str :: <string>) ndigs strip-0s)
  (let* ((n (- (string-length str) 1))
	 (res
	  (cond ((< ndigs 0) "")
		((= n ndigs) str)
		((< n ndigs)
		 (let ((padlen (max 0 (- (or strip-0s ndigs) n))))
		   (if (zero? padlen)
		       str
		       (string-append str
				      (make-string padlen
						   (if (char-numeric?
							(string-ref str n))
						       #\0 #\#))))))
		(else
		 (let ((res (substring str 0 (+ ndigs 1)))
		       (dig (lambda (i)
			      (let ((c (string-ref str i)))
				(if (char-numeric? c)
				    (string->number (string c))
				    0)))))
		   (let ((ldig (dig (+ 1 ndigs))))
		     (if (or (> ldig 5)
			     (and (= ldig 5)
				  (let loop ((i (+ 2 ndigs)))
				    (if (> i n)
					(odd? (dig ndigs))
					(if (zero? (dig i))
					    (loop (+ i 1))
					    #t)))))
			 (let inc! ((i ndigs))
			   (let ((d (dig i)))
			     (if (< d 9)
				 (string-set! res i
					      (string-ref
					       (number->string (+ d 1)) 0))
				 (begin
				   (string-set! res i #\0)
				   (inc! (- i 1))))))))
		   res)))))
    (if strip-0s
	(let loop ((i (- (string-length res) 1)))
	  (if (or (<= i strip-0s)
		  (not (char=? #\0 (string-ref res i))))
	      (substring res 0 (+ i 1))
	      (loop (- i 1))))
	res)))

(define-constant (stdio:iprintf out format-string . args)
  (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)
	(error 'printf "conversion specification incomplete"
	       format-string))
      (define (wna)
	(error 'printf "wrong number of arguments"
	       (length args) format-string))
      (define (out* strs)
	(if (string? strs) (out strs)
	    (let out-loop ((strs strs))
	      (or (null? strs)
		  (and (out (car strs))
		       (out-loop (cdr strs)))))))

      (let loop ((args args))
	(advance)
	(cond
	 ((end-of-format?)
	  ;;(or (null? args) (wna))	;Extra arguments are *not* a bug.
	  )
	 ((eqv? #\\ fc);;Emulating C strings may not be a good idea.
	  (must-advance)
	  (and (case fc
		 ((#\n #\N) (out #\newline))
		 ((#\t #\T) (out #\tab))
		 ;;((#\r #\R) (out #\return))
		 ((#\f #\F) (out #\page))
		 ((#\newline) #t)
		 (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 (pad pre . strs)
	      (let loop ((len (string-length pre))
			 (ss strs))
		(cond ((>= len width) (cons pre strs))
		      ((null? ss)
		       (cond (left-adjust
			      (cons pre
				    (append strs
					    (list (make-string
						   (- width len) #\space)))))
			     (leading-0s
			      (cons pre
				    (cons (make-string (- width len) #\0)
					  strs)))
			     (else
			      (cons (make-string (- width len) #\space)
				    (cons pre strs)))))
		      (else
		       (loop (+ len (string-length (car ss))) (cdr ss))))))
	    (define integer-convert
	      (lambda (s radix fixcase)
		(cond ((not (negative? precision))
		       (set! leading-0s #f)
		       (if (and (zero? precision)
				(eqv? 0 s))
			   (set! s ""))))
		(set! s (cond ((symbol? s) (symbol->string s))
			      ((number? s) (number->string s radix))
			      ((or (not s) (null? s)) "0")
			      ((string? s) s)
			      (else "1")))
		(if fixcase (set! s (fixcase s)))
		(let ((pre (cond ((equal? "" s) "")
				 ((eqv? #\- (string-ref s 0))
				  (set! s (substring s 1 (string-length s)))
				  "-")
				 (signed "+")
				 (blank " ")
				 (alternate-form
				  (case radix