summaryrefslogtreecommitdiffstats
path: root/scanf.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:29 -0800
commit8466d8cfa486fb30d1755c4261b781135083787b (patch)
treec8c12c67246f543c3cc4f64d1c07e003cb1d45ae /scanf.scm
parent87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff)
downloadslib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz
slib-8466d8cfa486fb30d1755c4261b781135083787b.zip
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'scanf.scm')
-rw-r--r--scanf.scm514
1 files changed, 252 insertions, 262 deletions
diff --git a/scanf.scm b/scanf.scm
index 7122d95..a79595f 100644
--- a/scanf.scm
+++ b/scanf.scm
@@ -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)))