diff options
Diffstat (limited to 'scanf.scm')
| -rw-r--r-- | scanf.scm | 514 |
1 files changed, 252 insertions, 262 deletions
@@ -1,5 +1,5 @@ -;;;;"scanf.scm" implemenation of formated input -;Copyright (C) 1996, 1997 Aubrey Jaffer +;;;;"scanf.scm" implemenation of formatted input +;Copyright (C) 1996, 1997, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;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 +;2. I have made no warranty 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. ; @@ -23,281 +23,274 @@ ;;; functions starting from the POSIX man pages. (require 'string-port) +(require 'rev2-procedures) +(require 'rev4-optional-procedures) (define (stdio:scan-and-set format-string input-port . args) - (define setters args) - (if (equal? '(#f) args) (set! args #f)) + (define setters (if (equal? '(#f) args) #f args)) + (define assigned-count 0) + (define chars-scanned 0) + (define items '()) + (define (return) + (cond ((and (zero? chars-scanned) + (eof-object? (peek-char input-port))) + (peek-char input-port)) + (setters assigned-count) + (else (reverse items)))) (cond - ((not (equal? "" format-string)) + ((equal? "" format-string) (return)) + ((string? input-port) (call-with-input-string - format-string - (lambda (format-port) - - (define items '()) - (define chars-scanned 0) - (define assigned-count 0) + input-port + (lambda (str-port) + (apply stdio:scan-and-set format-string str-port args)))) + (else + (call-with-input-string + format-string + (lambda (format-port) - (define (char-non-numeric? c) (not (char-numeric? c))) + (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 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 (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 (read-input-char) + (set! chars-scanned (+ 1 chars-scanned)) + (read-char input-port)) - (define (add-item report-field? next-item) - (cond (args - (cond ((and report-field? (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 (add-item report-field? next-item) + (cond (setters + (cond ((and report-field? (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-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 (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 (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 (width--) (if width (set! width (+ -1 width)))) + (define (read-u) + (string->number (read-string width char-non-numeric?))) - (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-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-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-radixed-unsigned) - (let ((c (peek-char input-port))) - (case c - ((#\0) (read-input-char) + (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--) - (set! c (peek-char input-port)) - (case c - ((#\x #\X) (read-input-char) - (width--) - (read-x)) - (else (read-o)))) - (else (read-u))))) + (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-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)))) - (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) - ;;(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)) + (c (peek-char input-port) (peek-char input-port))) + ((or (>= i width) + (eof-object? c)) + (add-item report-field? (substring str 0 i))) + (string-set! str i (read-input-char))))) + ((#\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)))) - (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)) - (c (peek-char input-port) (peek-char input-port))) - ((or (>= i width) - (eof-object? c)) - (add-item report-field? (substring str 0 i))) - (string-set! str i (read-input-char))))) - ((#\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)))) - ;;(trace flush-whitespace-input flush-whitespace add-item return read-string read-word loop1) - (loop1)))) - (args 0) - (else '()))) + (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)))) + ;;(trace flush-whitespace-input flush-whitespace add-item return read-string read-word loop1) + (loop1)))))) ;;;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)) @@ -308,8 +301,8 @@ (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)))) + input-port (lambda (input-port) + (stdio:scan-and-set format-string input-port #f)))) (else (slib:error 'scanf-read-list "argument 2 not a port" input-port)))) @@ -322,29 +315,26 @@ (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))))) - + `(stdio:scan-and-set ,format-string ,str + ,@(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))) |