diff options
Diffstat (limited to 'scanf.scm')
| -rw-r--r-- | scanf.scm | 351 |
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))) |