X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/8a7391cd1adc8606d233c56c41cfa06de7e8a9df..cf4e2dabf48fc42bbd4c8df7dd6f19e05903954c:/ice-9/format.scm

diff --git a/ice-9/format.scm b/ice-9/format.scm
index fce2737ce..486dc7277 100644
--- a/ice-9/format.scm
+++ b/ice-9/format.scm
@@ -11,11 +11,14 @@
 ;
 ; Version 3.0
 
-(define-module (ice-9 format))
-(export format
-	format:symbol-case-conv
-	format:iobj-case-conv
-	format:expch)
+(define-module (ice-9 format)
+  :use-module (ice-9 and-let-star)
+  :use-module (ice-9 threads)
+  :autoload (ice-9 pretty-print) (pretty-print)
+  :replace (format)
+  :export (format:symbol-case-conv
+	   format:iobj-case-conv
+	   format:expch))
 
 ;;; Configuration ------------------------------------------------------------
 
@@ -86,7 +89,7 @@
   (do ((k i (+ k 1)))
       ((= k n))
     (write-char (string-ref str k) format:port))
-  (set! format:output-col (+ format:output-col n)))
+  (set! format:output-col (+ format:output-col (- n i))))
 
 ;(define (format:out-fill n ch)       ; this allocates a new string
 ;  (format:out-str (make-string n ch)))
@@ -175,6 +178,8 @@
   (set! format:port port)		; global port for output routines
   (set! format:case-conversion #f)	; modifier case conversion procedure
   (set! format:flush-output #f)		; ~! reset
+  (and-let* ((col (port-column port)))	; get current column from port
+    (set! format:output-col col))
   (let ((arg-pos (format:format-work fmt args))
 	(arg-len (length args)))
     (cond
@@ -445,7 +450,6 @@
 	       (format:tabulate modifier params)
 	       (anychar-dispatch))
 	      ((#\Y)			; Pretty-print
-	       (require 'pretty-print)
 	       (pretty-print (next-arg) format:port)
 	       (set! format:output-col 0)
 	       (anychar-dispatch))
@@ -775,68 +779,100 @@
 ;; quoted strings so that the output can always be processed by (read)
 
 (define (format:obj->str obj slashify)
-  (cond
-   ((string? obj)
-    (if slashify
-	(let ((obj-len (string-length obj)))
-	  (string-append
-	   "\""
-	   (let loop ((i 0) (j 0))	; taken from Marc Feeley's pp.scm
-	     (if (= j obj-len)
-		 (string-append (substring obj i j) "\"")
-		 (let ((c (string-ref obj j)))
-		   (if (or (char=? c #\\)
-			   (char=? c #\"))
-		       (string-append (substring obj i j) "\\"
-				      (loop j (+ j 1)))
-		       (loop i (+ j 1))))))))
-	obj))
+  (define (obj->str obj slashify visited)
+    (if (memq obj (cdr visited))
+	(let ((n (- (list-index (cdr visited) (cdr obj)))))
+	  (string-append "#" (number->string n) "#"))
+	(cond
+	 ((string? obj)
+	  (if slashify
+	      (let ((obj-len (string-length obj)))
+		(string-append
+		 "\""
+		 (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm
+		   (if (= j obj-len)
+		       (string-append (substring obj i j) "\"")
+		       (let ((c (string-ref obj j)))
+			 (if (or (char=? c #\\)
+				 (char=? c #\"))
+			     (string-append (substring obj i j) "\\"
+					    (loop j (+ j 1)))
+			     (loop i (+ j 1))))))))
+	      obj))
    
-   ((boolean? obj) (if obj "#t" "#f"))
+	 ((boolean? obj) (if obj "#t" "#f"))
    
-   ((number? obj) (number->string obj))
+	 ((number? obj) (number->string obj))
 
-   ((symbol? obj) 
-    (if format:symbol-case-conv
-	(format:symbol-case-conv (symbol->string obj))
-	(symbol->string obj)))
+	 ((symbol? obj) 
+	  (if format:symbol-case-conv
+	      (format:symbol-case-conv (symbol->string obj))
+	      (symbol->string obj)))
    
-   ((char? obj)
-    (if slashify
-	(format:char->str obj)
-	(string obj)))
+	 ((char? obj)
+	  (if slashify
+	      (format:char->str obj)
+	      (string obj)))
    
-   ((null? obj) "()")
+	 ((null? obj) "()")
 
-   ((input-port? obj)
-    (format:iobj->str obj))
+	 ((input-port? obj)
+	  (format:iobj->str obj))
    
-   ((output-port? obj)
-    (format:iobj->str obj))
+	 ((output-port? obj)
+	  (format:iobj->str obj))
      
-   ((list? obj)
-    (string-append "("
-		   (let loop ((obj-list obj))
-		     (if (null? (cdr obj-list))
-			 (format:obj->str (car obj-list) #t)
-			 (string-append
-			  (format:obj->str (car obj-list) #t)
-			  " "
-			  (loop (cdr obj-list)))))
-		   ")"))
-
-   ((pair? obj)
-    (string-append "("
-		   (format:obj->str (car obj) #t)
-		   " . "
-		   (format:obj->str (cdr obj) #t)
-		   ")"))
-   
-   ((vector? obj)
-    (string-append "#" (format:obj->str (vector->list obj) #t)))
-
-   (else				; only objects with an #<...> 
-    (format:iobj->str obj))))		; representation should fall in here
+	 ((pair? obj)
+	  (string-append "("
+			 (let loop ((obj-list obj)
+				    (visited visited)
+				    (offset 0)
+				    (prefix ""))
+			   (cond ((null? (cdr obj-list))
+				  (string-append
+				   prefix
+				   (obj->str (car obj-list)
+					     #t
+					     (cons (car obj-list) visited))))
+				 ((memq (cdr obj-list) visited)
+				  (string-append
+				   prefix
+				   (obj->str (car obj-list)
+					     #t
+					     (cons (car obj-list) visited))
+				   " . #"
+				   (number->string
+				    (- offset
+				       (list-index visited (cdr obj-list))))
+				   "#"))
+				 ((pair? (cdr obj-list))
+				  (loop (cdr obj-list)
+					(cons (cdr obj-list) visited)
+					(+ 1 offset)
+					(string-append
+					 prefix
+					 (obj->str (car obj-list)
+						   #t
+						   (cons (car obj-list) visited))
+					 " ")))
+				 (else
+				  (string-append
+				   prefix
+				   (obj->str (car obj-list)
+					     #t
+					     (cons (car obj-list) visited))
+				   " . "
+				   (obj->str (cdr obj-list)
+					     #t
+					     (cons (cdr obj-list) visited))))))
+			 ")"))
+
+	 ((vector? obj)
+	  (string-append "#" (obj->str (vector->list obj) #t visited)))
+
+	 (else				; only objects with an #<...> 
+	  (format:iobj->str obj)))))	; representation should fall in here
+  (obj->str obj slashify (list obj)))
 
 ;; format:iobj->str reveals the implementation dependent representation of 
 ;; #<...> objects with the use of display and call-with-output-string.
@@ -1167,6 +1203,31 @@
 				(list-ref format:ordinal-ones-list ones))))
 			))))))))
 
+;; format inf and nan.
+
+(define (format:out-inf-nan number width digits edigits overch padch)
+  ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
+  ;; "+nan.0", suitably justified in their field.  We insist on
+  ;; printing this exact form so that the numbers can be read back in.
+
+  (let* ((str (number->string number))
+	 (len (string-length str))
+	 (dot (string-index str #\.))
+	 (digits (+ (or digits 0)
+		    (if edigits (+ edigits 2) 0))))
+    (if (and width overch (< width len))
+	(format:out-fill width (integer->char overch))
+	(let* ((leftpad (if width
+			    (max (- width (max len (+ dot 1 digits))) 0)
+			    0))
+	       (rightpad (if width
+			     (max (- width leftpad len) 0)
+			     0))
+	       (padch (integer->char (or padch format:space-ch)))) 
+	  (format:out-fill leftpad padch)
+	  (format:out-str str)
+	  (format:out-fill rightpad padch)))))
+
 ;; format fixed flonums (~F)
 
 (define (format:out-fixed modifier number pars)
@@ -1180,51 +1241,53 @@
 	  (overch (format:par pars l 3 #f #f))
 	  (padch (format:par pars l 4 format:space-ch #f)))
 
-    (if digits
+    (cond
+     ((or (inf? number) (nan? number))
+      (format:out-inf-nan number width digits #f overch padch))
+
+     (digits
+      (format:parse-float 
+       (if (string? number) number (number->string number)) #t scale)
+      (if (<= (- format:fn-len format:fn-dot) digits)
+	  (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+	  (format:fn-round digits))
+      (if width
+	  (let ((numlen (+ format:fn-len 1)))
+	    (if (or (not format:fn-pos?) (eq? modifier 'at))
+		(set! numlen (+ numlen 1)))
+	    (if (and (= format:fn-dot 0) (> width (+ digits 1)))
+		(set! numlen (+ numlen 1)))
+	    (if (< numlen width)
+		(format:out-fill (- width numlen) (integer->char padch)))
+	    (if (and overch (> numlen width))
+		(format:out-fill width (integer->char overch))
+		(format:fn-out modifier (> width (+ digits 1)))))
+	  (format:fn-out modifier #t)))
 
-	(begin				; fixed precision
-	  (format:parse-float 
-	   (if (string? number) number (number->string number)) #t scale)
-	  (if (<= (- format:fn-len format:fn-dot) digits)
-	      (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
-	      (format:fn-round digits))
-	  (if width
-	      (let ((numlen (+ format:fn-len 1)))
-		(if (or (not format:fn-pos?) (eq? modifier 'at))
-		    (set! numlen (+ numlen 1)))
-		(if (and (= format:fn-dot 0) (> width (+ digits 1)))
-		    (set! numlen (+ numlen 1)))
-		(if (< numlen width)
-		    (format:out-fill (- width numlen) (integer->char padch)))
-		(if (and overch (> numlen width))
-		    (format:out-fill width (integer->char overch))
-		    (format:fn-out modifier (> width (+ digits 1)))))
-	      (format:fn-out modifier #t)))
-
-	(begin				; free precision
-	  (format:parse-float
-	   (if (string? number) number (number->string number)) #t scale)
-	  (format:fn-strip)
-	  (if width
-	      (let ((numlen (+ format:fn-len 1)))
-		(if (or (not format:fn-pos?) (eq? modifier 'at))
-		    (set! numlen (+ numlen 1)))
-		(if (= format:fn-dot 0)
-		    (set! numlen (+ numlen 1)))
-		(if (< numlen width)
-		    (format:out-fill (- width numlen) (integer->char padch)))
-		(if (> numlen width)	; adjust precision if possible
-		    (let ((dot-index (- numlen
-					(- format:fn-len format:fn-dot))))
-		      (if (> dot-index width)
-			  (if overch	; numstr too big for required width
-			      (format:out-fill width (integer->char overch))
-			      (format:fn-out modifier #t))
-			  (begin
-			    (format:fn-round (- width dot-index))
-			    (format:fn-out modifier #t))))
-		    (format:fn-out modifier #t)))
-	      (format:fn-out modifier #t)))))))
+     (else
+      (format:parse-float
+       (if (string? number) number (number->string number)) #t scale)
+      (format:fn-strip)
+      (if width
+	  (let ((numlen (+ format:fn-len 1)))
+	    (if (or (not format:fn-pos?) (eq? modifier 'at))
+		(set! numlen (+ numlen 1)))
+	    (if (= format:fn-dot 0)
+		(set! numlen (+ numlen 1)))
+	    (if (< numlen width)
+		(format:out-fill (- width numlen) (integer->char padch)))
+	    (if (> numlen width)	; adjust precision if possible
+		(let ((dot-index (- numlen
+				    (- format:fn-len format:fn-dot))))
+		  (if (> dot-index width)
+		      (if overch	; numstr too big for required width
+			  (format:out-fill width (integer->char overch))
+			  (format:fn-out modifier #t))
+		      (begin
+			(format:fn-round (- width dot-index))
+			(format:fn-out modifier #t))))
+		(format:fn-out modifier #t)))
+	  (format:fn-out modifier #t)))))))
 
 ;; format exponential flonums (~E)
 
@@ -1240,8 +1303,12 @@
 	  (overch (format:par pars l 4 #f #f))
 	  (padch (format:par pars l 5 format:space-ch #f))
 	  (expch (format:par pars l 6 #f #f)))
-	 
-    (if digits				; fixed precision
+	
+      (cond
+       ((or (inf? number) (nan? number))
+	(format:out-inf-nan number width digits edigits overch padch))
+
+       (digits				; fixed precision
 
 	(let ((digits (if (> scale 0)
 			  (if (< scale (+ digits 2))
@@ -1276,47 +1343,47 @@
 			  (format:en-out edigits expch)))))
 	      (begin
 		(format:fn-out modifier #t)
-		(format:en-out edigits expch))))
+		(format:en-out edigits expch)))))
 
-	(begin				; free precision
-	  (format:parse-float
-	   (if (string? number) number (number->string number)) #f scale)
-	  (format:fn-strip)
-	  (if width
-	      (if (and edigits overch (> format:en-len edigits))
-		  (format:out-fill width (integer->char overch))
-		  (let ((numlen (+ format:fn-len 3))) ; .E+
-		    (if (or (not format:fn-pos?) (eq? modifier 'at))
-			(set! numlen (+ numlen 1)))
-		    (if (= format:fn-dot 0)
-			(set! numlen (+ numlen 1)))
-		    (set! numlen
-			  (+ numlen
-			     (if (and edigits (>= edigits format:en-len))
-				 edigits 
-				 format:en-len)))
-		    (if (< numlen width)
-			(format:out-fill (- width numlen)
-					 (integer->char padch)))
-		    (if (> numlen width) ; adjust precision if possible
-			(let ((f (- format:fn-len format:fn-dot))) ; fract len
-			  (if (> (- numlen f) width)
-			      (if overch ; numstr too big for required width
-				  (format:out-fill width 
-						   (integer->char overch))
-				  (begin
-				    (format:fn-out modifier #t)
-				    (format:en-out edigits expch)))
-			      (begin
-				(format:fn-round (+ (- f numlen) width))
-				(format:fn-out modifier #t)
-				(format:en-out edigits expch))))
-			(begin
-			  (format:fn-out modifier #t)
-			  (format:en-out edigits expch)))))
-	      (begin
-		(format:fn-out modifier #t)
-		(format:en-out edigits expch))))))))
+       (else
+	(format:parse-float
+	 (if (string? number) number (number->string number)) #f scale)
+	(format:fn-strip)
+	(if width
+	    (if (and edigits overch (> format:en-len edigits))
+		(format:out-fill width (integer->char overch))
+		(let ((numlen (+ format:fn-len 3))) ; .E+
+		  (if (or (not format:fn-pos?) (eq? modifier 'at))
+		      (set! numlen (+ numlen 1)))
+		  (if (= format:fn-dot 0)
+		      (set! numlen (+ numlen 1)))
+		  (set! numlen
+			(+ numlen
+			   (if (and edigits (>= edigits format:en-len))
+			       edigits 
+			       format:en-len)))
+		  (if (< numlen width)
+		      (format:out-fill (- width numlen)
+				       (integer->char padch)))
+		  (if (> numlen width) ; adjust precision if possible
+		      (let ((f (- format:fn-len format:fn-dot))) ; fract len
+			(if (> (- numlen f) width)
+			    (if overch ; numstr too big for required width
+				(format:out-fill width 
+						 (integer->char overch))
+				(begin
+				  (format:fn-out modifier #t)
+				  (format:en-out edigits expch)))
+			    (begin
+			      (format:fn-round (+ (- f numlen) width))
+			      (format:fn-out modifier #t)
+			      (format:en-out edigits expch))))
+		      (begin
+			(format:fn-out modifier #t)
+			(format:en-out edigits expch)))))
+	    (begin
+	      (format:fn-out modifier #t)
+	      (format:en-out edigits expch))))))))
 	
 ;; format general flonums (~G)
 
@@ -1330,23 +1397,28 @@
 	  (edigits (if (> l 2) (list-ref pars 2) #f))
 	  (overch (if (> l 4) (list-ref pars 4) #f))
 	  (padch (if (> l 5) (list-ref pars 5) #f)))
-    (format:parse-float
-     (if (string? number) number (number->string number)) #t 0)
-    (format:fn-strip)
-    (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
-	   (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
-	   (n (if (= format:fn-dot 0)	; number less than (abs 1.0) ?
-		  (- (format:fn-zlead))
-		  format:fn-dot))
-	   (d (if digits
-		  digits
-		  (max format:fn-len (min n 7)))) ; q = format:fn-len
-	   (dd (- d n)))
-      (if (<= 0 dd d)
-	  (begin
-	    (format:out-fixed modifier number (list ww dd #f overch padch))
-	    (format:out-fill ee #\space)) ;~@T not implemented yet
-	  (format:out-expon modifier number pars))))))
+      (cond
+       ((or (inf? number) (nan? number))
+	;; FIXME: this isn't right.
+	(format:out-inf-nan number width digits edigits overch padch))
+       (else
+	(format:parse-float
+	 (if (string? number) number (number->string number)) #t 0)
+	(format:fn-strip)
+	(let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
+	       (ww (if width (- width ee) #f))   ; see Steele's CL book p.395
+	       (n (if (= format:fn-dot 0)	; number less than (abs 1.0) ?
+		      (- (format:fn-zlead))
+		      format:fn-dot))
+	       (d (if digits
+		      digits
+		      (max format:fn-len (min n 7)))) ; q = format:fn-len
+	       (dd (- d n)))
+	  (if (<= 0 dd d)
+	      (begin
+		(format:out-fixed modifier number (list ww dd #f overch padch))
+		(format:out-fill ee #\space)) ;~@T not implemented yet
+	      (format:out-expon modifier number pars))))))))
 
 ;; format dollar flonums (~$)
 
@@ -1401,7 +1473,7 @@
 
 ; the flonum buffers
 
-(define format:fn-max 200)		; max. number of number digits
+(define format:fn-max 400)		; max. number of number digits
 (define format:fn-str (make-string format:fn-max)) ; number buffer
 (define format:fn-len 0)		; digit length of number
 (define format:fn-dot #f)		; dot position of number
@@ -1634,17 +1706,6 @@
 
 ;;; some global functions not found in SLIB
 
-;; string-index finds the index of the first occurence of the character `c'
-;; in the string `s'; it returns #f if there is no such character in `s'.
-
-(define (string-index s c)
-  (let ((slen-1 (- (string-length s) 1)))
-    (let loop ((i 0))
-      (cond
-       ((char=? c (string-ref s i)) i)
-       ((= i slen-1) #f)
-       (else (loop (+ i 1)))))))
-
 (define (string-capitalize-first str)	; "hello" -> "Hello"
   (let ((cap-str (string-copy str))	; "hELLO" -> "Hello"
 	(non-first-alpha #f)		; "*hello" -> "*Hello"
@@ -1659,18 +1720,15 @@
 		  (set! non-first-alpha #t)
 		  (string-set! cap-str i (char-upcase c)))))))))
 
-(define (list-head l k)
-  (if (= k 0)
-      '()
-      (cons (car l) (list-head (cdr l) (- k 1)))))
-
-
 ;; Aborts the program when a formatting error occures. This is a null
 ;; argument closure to jump to the interpreters toplevel continuation.
 
 (define format:abort (lambda () (error "error in format")))
 
-(define format format:format)
+(define (format . args) (monitor (apply format:format args)))
+
+;; Thanks to Shuji Narazaki
+(module-set! the-root-module 'format format)
 
 ;; If this is not possible then a continuation is used to recover
 ;; properly from a format error. In this case format returns #f.