-;;; installed-scm-file
-
-;;;; Copyright (C) 1996, 1998 Free Software Foundation, Inc.
+;;;; Copyright (C) 1996, 1998, 1999 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
(let ((,c (read-char ,port)))
(if expect-char-proc
(expect-char-proc ,c))
- (cond ((eof-object? ,c)
- (if expect-eof-proc
- (expect-eof-proc ,s)
- #f))
+ (if (not (eof-object? ,c))
+ (set! ,s (string-append ,s (string ,c))))
+ (cond
+ ;; this expands to clauses where the car invokes the match proc and
+ ;; the cdr is the return value from expect if the proc matched.
+ ,@(let next-expr ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (body '()))
+ (cond
+ ((null? tests)
+ (reverse body))
(else
- (set! ,s (string-append ,s (string ,c)))
- (cond
- ,@(let next-expr ((tests (map car clauses))
- (exprs (map cdr clauses))
- (body '()))
- (cond
- ((null? tests)
- (reverse body))
+ (next-expr
+ (cdr tests)
+ (cdr exprs)
+ (cons
+ `((,(car tests) ,s (eof-object? ,c))
+ ,@(cond ((null? (car exprs))
+ '())
+ ((eq? (caar exprs) '=>)
+ (if (not (= (length (car exprs))
+ 2))
+ (scm-error 'misc-error
+ "expect"
+ "bad recipient: %S"
+ (list (car exprs))
+ #f)
+ `((apply ,(cadar exprs)
+ (,(car tests) ,s ,port)))))
+ (else
+ (car exprs))))
+ body)))))
+ ;; if none of the clauses matched the current string.
+ (else (cond ((eof-object? ,c)
+ (if expect-eof-proc
+ (expect-eof-proc ,s)
+ #f))
(else
- (next-expr
- (cdr tests)
- (cdr exprs)
- (cons
- `((,(car tests) ,s)
- ,@(cond ((null? (car exprs))
- '())
- ((eq? (caar exprs) '=>)
- (if (not (= (length (car exprs))
- 2))
- (scm-error 'misc-error
- "expect"
- "bad recipient: %S"
- (list (car exprs))
- #f)
- `((apply ,(cadar exprs)
- (,(car tests) ,s)))))
- (else
- (car exprs))))
- body)))))
- (else (next-char)))))))))))
+ (next-char)))))))))))
+
+
+(define-public expect-strings-compile-flags regexp/newline)
+(define-public expect-strings-exec-flags regexp/noteol)
;;; the regexec front-end to expect:
;;; each test must evaluate to a regular expression.
(let ((rxname (gentemp)))
(next-test (cdr tests)
(cdr exprs)
- (cons `(,rxname (make-regexp ,(car tests)
- regexp/newline))
+ (cons `(,rxname (make-regexp
+ ,(car tests)
+ expect-strings-compile-flags))
defs)
- (cons `((lambda (s)
- (expect-regexec ,rxname s))
+ (cons `((lambda (s eof?)
+ (expect-regexec ,rxname s eof?))
,@(car exprs))
body))))))))
(pair? (car (select (list port) '() '()
relative))))))
-;;; convert a match object to a list of strings, for the => syntax.
-(define-public (expect-regexec rx s)
- (let ((match (regexp-exec rx s)))
+;;; match a string against a regexp, returning a list of strings (required
+;;; by the => syntax) or #f. called once each time a character is added
+;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
+(define-public (expect-regexec rx s eof?)
+ ;; if expect-strings-exec-flags contains regexp/noteol,
+ ;; remove it for the eof test.
+ (let* ((flags (if (and eof?
+ (logand expect-strings-exec-flags regexp/noteol))
+ (logxor expect-strings-exec-flags regexp/noteol)
+ expect-strings-exec-flags))
+ (match (regexp-exec rx s 0 flags)))
(if match
(do ((i (- (match:count match) 1) (- i 1))
(result '() (cons (match:substring match i) result)))
((< i 0) result))
#f)))
+
HCoop / bpt / guile.git / blobdiff