summaryrefslogtreecommitdiffstats
path: root/scanf.scm
diff options
context:
space:
mode:
Diffstat (limited to 'scanf.scm')
-rw-r--r--scanf.scm351
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)))