Import Upstream version 2a6upstream/2a6

1 files changed, 351 insertions, 0 deletions

diff --git a/scanf.scm b/scanf.scm
new file mode 100644
index 0000000..b1ae30a
--- /dev/null
+++ b/scanf.scm
@@ -0,0 +1,351 @@
+;;;;"scanf.scm" implemenation of formated input
+;Copyright (C) 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.
+
+;;; Originally jjb@isye.gatech.edu (John Bartholdi) wrote some public
+;;; domain code for a subset of scanf, but it was too difficult to
+;;; extend to POSIX pattern compliance.  Jan 96, I rewrote the scanf
+;;; functions starting from the POSIX man pages.
+
+(require 'string-port)
+
+(define (stdio:scan-and-set format-string input-port . args)
+  (define setters args)
+  (if (equal? '(#f) args) (set! args #f))
+  (cond
+   ((not (equal? "" format-string))
+    (call-with-input-string
+     format-string
+     (lambda (format-port)
+
+       (define items '())
+       (define chars-scanned 0)
+       (define assigned-count 0)
+
+       (define (char-non-numeric? c) (not (char-numeric? c)))
+
+       (define (flush-whitespace port)
+	 (do ((c (peek-char port) (peek-char port))
+	      (i 0 (+ 1 i)))
+	     ((or (eof-object? c) (not (char-whitespace? c))) i)
+	   (read-char port)))
+
+       (define (flush-whitespace-input)
+	 (set! chars-scanned (+ (flush-whitespace input-port) chars-scanned)))
+
+       (define (read-input-char)
+	 (set! chars-scanned (+ 1 chars-scanned))
+	 (read-char input-port))
+
+       (define (add-item report-field? next-item)
+	 (cond (args
+		(cond ((null? setters)
+		       (slib:error 'scanf "not enough variables for format"
+				   format-string))
+		      ((not next-item) (return))
+		      ((not report-field?) (loop1))
+		      (else
+		       (let ((suc ((car setters) next-item)))
+			 (cond ((not (boolean? suc))
+				(slib:warn 'scanf "setter returned non-boolean"
+					   suc)))
+			 (set! setters (cdr setters))
+			 (cond ((not suc) (return))
+			       ((eqv? -1 report-field?) (loop1))
+			       (else
+				(set! assigned-count (+ 1 assigned-count))
+				(loop1)))))))
+	       ((not next-item) (return))
+	       (report-field? (set! items (cons next-item items))
+			      (loop1))
+	       (else (loop1))))
+
+       (define (return)
+	 (cond ((and (zero? chars-scanned)
+		     (eof-object? (peek-char input-port)))
+		(peek-char input-port))
+	       (args assigned-count)
+	       (else (reverse items))))
+
+       (define (read-string width separator?)
+	 (cond (width
+		(let ((str (make-string width)))
+		  (do ((i 0 (+ 1 i)))
+		      ((>= i width)
+		       str)
+		    (let ((c (peek-char input-port)))
+		      (cond ((eof-object? c)
+			     (set! str (substring str 0 i))
+			     (set! i width))
+			    ((separator? c)
+			     (set! str (if (zero? i) "" (substring str 0 i)))
+			     (set! i width))
+			    (else
+			     (string-set! str i (read-input-char))))))))
+	       (else
+		(do ((c (peek-char input-port) (peek-char input-port))
+		     (l '() (cons c l)))
+		    ((or (eof-object? c) (separator? c))
+		     (list->string (reverse l)))
+		  (read-input-char)))))
+
+       (define (read-word width separator?)
+	 (let ((l (read-string width separator?)))
+	   (if (zero? (string-length l)) #f l)))
+
+       (define (loop1)
+	 (define fc (read-char format-port))
+	 (cond
+	  ((eof-object? fc)
+	   (return))
+	  ((char-whitespace? fc)
+	   (flush-whitespace format-port)
+	   (flush-whitespace-input)
+	   (loop1))
+	  ((eqv? #\% fc)		; interpret next format
+	   (set! fc (read-char format-port))
+	   (let ((report-field? (not (eqv? #\* fc)))
+		 (width #f))
+
+	     (define (width--) (if width (set! width (+ -1 width))))
+
+	     (define (read-u)
+	       (string->number (read-string width char-non-numeric?)))
+
+	     (define (read-o)
+	       (string->number
+		(read-string
+		 width
+		 (lambda (c) (not (memv c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)))))
+		8))
+
+	     (define (read-x)
+	       (string->number
+		(read-string
+		 width
+		 (lambda (c) (not (memv (char-downcase c)
+					'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8
+					      #\9 #\a #\b #\c #\d #\e #\f)))))
+		16))
+
+	     (define (read-radixed-unsigned)
+	       (let ((c (peek-char input-port)))
+		 (case c
+		   ((#\0) (read-input-char)
+			  (width--)
+			  (set! c (peek-char input-port))
+			  (case c
+			    ((#\x #\X) (read-input-char)
+				       (width--)
+				       (read-x))
+			    (else (read-o))))
+		   (else (read-u)))))
+
+	     (define (read-ui)
+	       (let* ((dot? #f)
+		      (mantissa (read-word
+				 width
+				 (lambda (c) 
+				   (not (or (char-numeric? c)
+					    (cond (dot? #f)
+						  ((eqv? #\. c)
+						   (set! dot? #t)
+						   #t)
+						  (else #f)))))))
+		      (exponent (cond
+				 ((not mantissa) #f)
+				 ((and (or (not width) (> width 1))
+				       (memv (peek-char input-port) '(#\E #\e)))
+				  (read-input-char)
+				  (width--)
+				  (let ((expsign
+					 (case (peek-char input-port)
+					   ((#\-) (read-input-char)
+						  (width--)
+						  "-")
+					   ((#\+) (read-input-char)
+						  (width--)
+						  "+")
+					   (else "")))
+					(expint
+					 (and
+					  (or (not width) (positive? width))
+					  (read-word width char-non-numeric?))))
+				    (and expint (string-append
+						 "e" expsign expint))))
+				 (else #f))))
+		 (and mantissa
+		      (string->number
+		       (string-append
+			"#i" (or mantissa "") (or exponent ""))))))
+
+	     (define (read-signed proc)
+	       (case (peek-char input-port)
+		 ((#\-) (read-input-char)
+			(width--)
+			(let ((ret (proc)))
+			  (and ret (- ret))))
+		 ((#\+) (read-input-char)
+			(width--)
+			(proc))
+		 (else (proc))))
+
+	     ;;(trace read-word read-signed read-ui read-radixed-unsigned read-x read-o read-u)
+
+	     (cond ((not report-field?) (set! fc (read-char format-port))))
+	     (if (char-numeric? fc) (set! width 0))
+	     (do () ((or (eof-object? fc) (char-non-numeric? fc)))
+	       (set! width (+ (* 10 width) (string->number (string fc))))
+	       (set! fc (read-char format-port)))
+	     (case fc			;ignore h,l,L modifiers.
+	       ((#\h #\l #\L) (set! fc (read-char format-port))))
+	     (case fc
+	       ((#\n) (if (not report-field?)
+			  (slib:error 'scanf "not saving %n??"))
+		      (add-item -1 chars-scanned)) ;-1 is special flag.
+	       ((#\c #\C)
+		(if (not width) (set! width 1))
+		(let ((str (make-string width)))
+		  (do ((i 0 (+ 1 i)))
+		      ((>= i width)
+		       (add-item report-field? str))
+		    (let ((c (read-char input-port)))
+		      (cond ((eof-object? c)
+			     (set! str c)
+			     (set! i width))
+			    (else (string-set! str i c)))))))
+	       ((#\s #\S)
+		;;(flush-whitespace-input)
+		(add-item report-field? (read-word width char-whitespace?)))
+	       ((#\[)
+		(set! fc (read-char format-port))
+		(let ((allbut #f))
+		  (case fc
+		    ((#\^) (set! allbut #t)
+			   (set! fc (read-char format-port))))
+
+		  (let scanloop ((scanset (list fc)))
+		    (set! fc (read-char format-port))
+		    (case fc
+		      ((#\-)
+		       (set! fc (peek-char format-port))
+		       (cond
+			((and (char<? (car scanset) fc)
+			      (not (eqv? #\] fc)))
+			 (set! fc (char->integer fc))
+			 (do ((i (char->integer (car scanset)) (+ 1 i)))
+			     ((> i fc) (scanloop scanset))
+			   (set! scanset (cons (integer->char i) scanset))))
+			(else (scanloop (cons #\- scanset)))))
+		      ((#\])
+		       (add-item report-field?
+				 (read-word
+				  width
+				  (if allbut (lambda (c) (memv c scanset))
+				      (lambda (c) (not (memv c scanset)))))))
+		      (else (cond
+			     ((eof-object? fc)
+			      (slib:error 'scanf "unmatched [ in format"))
+			     (else (scanloop (cons fc scanset)))))))))
+	       ((#\o #\O)
+		;;(flush-whitespace-input)
+		(add-item report-field? (read-o)))
+	       ((#\u #\U)
+		;;(flush-whitespace-input)
+		(add-item report-field? (read-u)))
+	       ((#\d #\D)
+		;;(flush-whitespace-input)
+		(add-item report-field? (read-signed read-u)))
+	       ((#\x #\X)
+		;;(flush-whitespace-input)
+		(add-item report-field? (read-x)))
+	       ((#\e #\E #\f #\F #\g #\G)
+		;;(flush-whitespace-input)
+		(add-item report-field? (read-signed read-ui)))
+	       ((#\i)
+		;;(flush-whitespace-input)
+		(add-item report-field? (read-signed read-radixed-unsigned)))
+	       ((#\%)
+		(cond ((or width (not report-field?))
+		       (slib:error 'SCANF "%% has modifiers?"))
+		      ((eqv? #\% (read-input-char))
+		       (loop1))
+		      (else (return))))
+	       (else (slib:error 'SCANF
+				 "Unknown format directive:" fc)))))
+	  ((eqv? (peek-char input-port) fc)
+	   (read-input-char)
+	   (loop1))
+	  (else (return))))
+
+       (loop1))))
+   (args 0)
+   (else '())))
+
+;;;This implements a Scheme-oriented version of SCANF: returns a list of
+;;;objects read (rather than set!-ing values).
+
+(define (scanf-read-list format-string . optarg)
+  (define input-port
+    (cond ((null? optarg) (current-input-port))
+	  ((not (null? (cdr optarg)))
+	   (slib:error 'scanf-read-list 'wrong-number-of-args optarg))
+	  (else (car optarg))))
+  (cond ((input-port? input-port)
+	 (stdio:scan-and-set format-string input-port #f))
+	((string? input-port)
+	 (call-with-input-string
+	  input-port (lambda (input-port)
+		       (stdio:scan-and-set format-string input-port #f))))
+	(else (slib:error 'scanf-read-list "argument not port" input-port))))
+
+(define (stdio:setter-procedure sexp)
+  (let ((v (gentemp)))
+    (cond ((symbol? sexp) `(lambda (,v) (set! ,sexp ,v) #t))
+	  ((not (and (pair? sexp) (list? sexp)))
+	   (slib:error 'scanf "setter expression not understood" sexp))
+	  (else
+	   (case (car sexp)
+	     ((vector-ref) `(lambda (,v) (vector-set! ,@(cdr sexp) ,v) #t))
+	     ((substring)
+	      (require 'rev2-procedures)
+	      `(lambda (,v) (substring-move-left!
+			     ,v 0 (min (string-length ,v)
+				       (- ,(cadddr sexp) ,(caddr sexp)))
+			     ,(cadr sexp) ,(caddr sexp))
+		       #t))
+	     ((list-ref)
+	      (require 'rev4-optional-procedures)
+	      `(lambda (,v) (set-car! (list-tail ,@(cdr sexp)) ,v) #t))
+	     ((car) `(lambda (,v) (set-car! ,@(cdr sexp) ,v) #t))
+	     ((cdr) `(lambda (,v) (set-cdr! ,@(cdr sexp) ,v) #t))
+	     (else (slib:error 'scanf "setter not known" sexp)))))))
+
+(defmacro scanf (format-string . args)
+  `(stdio:scan-and-set ,format-string (current-input-port)
+		       ,@(map stdio:setter-procedure args)))
+
+(defmacro sscanf (str format-string . args)
+  `(call-with-input-string
+    ,str (lambda (input-port)
+	   (stdio:scan-and-set ,format-string input-port
+			       ,@(map stdio:setter-procedure args)))))
+
+(defmacro fscanf (input-port format-string . args)
+  `(stdio:scan-and-set ,format-string ,input-port
+		       ,@(map stdio:setter-procedure args)))