- rewrote expect with a functional interface expect*

scheme/expect.scm

@@ -24,10 +24,6 @@
 ;;; - expect-package
 ;;;   This package must be opened by expect's clients.
 
-(define error (structure-ref signals error))
-
-(define-syntax expect expand-expect)
-
 ;;; A task is a guy with whom we can interact.
 
 (define-record-type task
@@ -285,3 +281,211 @@
   (let ((s (task:buf task)))
     (if (zero? (string-length s)) (otherwise)
 	(tm s s otherwise))))
+
+
+;;; expect functional interface
+
+(define *default-timeout* 10)
+(define *default-echo* #f)
+(define *default-max-size* #f)
+
+(define-record-type :eof-pattern
+  (make-eof-pattern)
+  eof-pattern?)
+
+(define eof-pattern (make-eof-pattern))
+
+(define (in-select! rvec timeout)
+  (receive (in out ex)
+	   (select! rvec '#() '#() timeout)
+	   (not (zero? in))))
+
+;; pattern: (match (lambda () regexp) (lambda (match) ...))
+;; or       (eof (lambda () ...))
+;; or       (test (lambda () #t/#f) (lambda (v) ...))
+;; or       (else (lambda () ...))  ; else
+
+(define (expect* options . tasks-patterns-alist)
+  (let ((monitor (cond
+		  ((assq 'monitor options) => cdr)
+		  (else null-monitor)))
+	(on-timeout (cond
+		     ((assq 'on-timeout options) => cdr)
+		     (else (lambda () #f))))
+	(timeout (cond
+		  ((assq 'timeout options) => cdr)
+		  (else *default-timeout*)))
+	(echo (cond
+	       ((assq 'echo options) => cdr)
+	       (else *default-echo*)))
+	(max-size (cond
+		   ((assq 'max-size options) => cdr)
+		   (else *default-max-size*))))
+    (expect-1* on-timeout monitor timeout echo max-size tasks-patterns-alist)))
+
+(define (expect-1* on-timeout monitor timeout echo max-size
+		   tasks-patterns-alist)
+  (let ((handle-input
+	 (lambda (task patterns input do-next)
+	   (let ((s (task:buf task)))
+	     (let loop ((patterns patterns))
+	       (if (null? patterns)
+		   (do-next)
+		   (let ((pattern (car patterns)))
+		     (case (car pattern)
+		       ((match)
+			(let ((m (string-match ((cadr pattern)) s)))
+			  (if m
+			      (begin
+				(do-match-hacking task m s input monitor)
+				(monitor task m) ;; ??
+				((caddr pattern) m))
+			      (loop (cdr patterns)))))
+		       ((eof) (loop (cdr patterns)))
+		       ((test)
+			(let ((v ((cadr pattern))))
+			  (if v
+			      ((caddr pattern) v)
+			      (loop (cdr patterns)))))
+		       ((else)
+			((cadr pattern)))
+		       (else (error "undefined pattern type" (car pattern)))
+		       )))))))
+	(handle-eof
+	 (lambda (task patterns do-next)
+	   (set-task:pre-match! task (task:buf task))
+	   (set-task:buf! task "")
+	   (monitor task #f)
+	   (let loop ((patterns patterns))
+	     (if (null? patterns)
+		 (do-next)
+		 (let ((pattern (car patterns)))
+		   (case (car pattern)
+		     ((eof) ((cadr pattern)))
+		     ((match test else) (loop (cdr patterns)))
+		     (else (error "undefined pattern type" (car pattern)))
+		     ))))))
+	(handle-timeout
+	 (lambda ()
+	   (monitor #f 'timeout)
+	   (on-timeout))))
+
+    ;; first check existing data in the buffers
+    (let loop ((f-tasks-patterns-alist tasks-patterns-alist))
+      (if (not (null? f-tasks-patterns-alist))
+	  (let* ((task-patterns (car f-tasks-patterns-alist))
+		 (task (car task-patterns))
+		 (s (task:buf task)))
+	    (if (not (zero? (string-length s)))
+		(handle-input task (cdr task-patterns) s
+			      (lambda () (loop (cdr f-tasks-patterns-alist))))
+		(loop (cdr f-tasks-patterns-alist))))
+
+	  ;; start looking for input, handle it and throw away those
+	  ;; that got eof
+	  (let loop ((tasks-patterns-alist tasks-patterns-alist))
+	    (if (null? tasks-patterns-alist)
+		#f ;; all eof
+		(let ((ivec (list->vector (map (lambda (task-patterns)
+						 (task:in (car task-patterns)))
+					       tasks-patterns-alist))))
+		  ;; what is this (time) thing in the original?
+		  (if (not (in-select! ivec timeout))
+		      (handle-timeout)
+		      (let iloop ((inports (vector->list ivec))
+				  (tasks-patterns-alist tasks-patterns-alist)
+				  (remaining '()))
+			(if (null? tasks-patterns-alist)
+			    (loop (reverse remaining))
+			    (if (car inports)
+				(let* ((task-patterns (car tasks-patterns-alist))
+				       (task (car task-patterns))
+				       (s (do-input task)))
+				  (if s
+				      (handle-input
+				       task (cdr task-patterns) s
+				       (lambda ()
+					 (iloop (cdr inports)
+						(cdr tasks-patterns-alist)
+						(cons task-patterns
+						      remaining))))
+				      (handle-eof
+				       task (cdr task-patterns)
+				       (lambda ()
+					 (iloop (cdr inports)
+						(cdr tasks-patterns-alist)
+						remaining)))))
+				(iloop (cdr inports)
+				       (cdr tasks-patterns-alist)
+				       (cons (car tasks-patterns-alist)
+					     remaining)))))))))))))
+
+;; Syntax based on procedural interface
+
+(define-syntax expect-options-clauses
+  (syntax-rules (on-timeout timeout echo max-size monitor)
+    ((expect-options-clauses)
+     '())
+    ((expect-options-clauses (on-timeout body ...) clause ...)
+     (cons (cons 'on-timeout (lambda () body ...))
+	   (expect-options-clauses clause ...)))
+    ((expect-options-clauses (timeout v) clause ...)
+     (cons (cons 'timeout v)
+	   (expect-options-clauses clause ...)))
+    ((expect-options-clauses (echo v) clause ...)
+     (cons (cons 'echo v)
+	   (expect-options-clauses clause ...)))
+    ((expect-options-clauses (max-size v) clause ...)
+     (cons (cons 'max-size v)
+	   (expect-options-clauses clause ...)))
+    ((expect-options-clauses (monitor proc) clause ...)
+     (cons (cons 'monitor proc)
+	   (expect-options-clauses clause ...)))
+    ((expect-options-clauses x clause ...)
+     (expect-options-clauses clause ...))))
+
+(define-syntax expect-action-clauses
+  (syntax-rules (on-eof test => else)
+    ((expect-action-clauses loop)
+     '())
+    ((expect-action-clauses loop (on-eof body ...) clause ...)
+     (cons (list 'eof
+		 (lambda () body ...))
+	   (expect-action-clauses loop clause ...)))
+    ((expect-action-clauses loop (test exp body ...) clause ...)
+     (cons (list 'test
+		 (lambda () exp)
+		 (lambda (_) body ...))
+	   (expect-action-clauses loop clause ...)))
+    ((expect-action-clauses loop (test exp => proc) clause ...)
+     (cons (list 'test
+		 (lambda () exp)
+		 (lambda (v) (proc v)))
+	   (expect-action-clauses loop clause ...)))
+    ((expect-action-clauses loop (pattern (mvars ...) body ...) clause ...)
+     (cons (list 'match (lambda () pattern)
+		 (lambda (m)
+		   (let-match m (mvars ...) body ...)))
+	   (expect-action-clauses loop clause ...)))
+    ((expect-action-clauses loop (else body ...) clause ...)
+     (cons (list else (lambda () body ...))
+	   (expect-action-clauses loop clause ...)))))
+
+(define-syntax expect-task-clauses
+  (syntax-rules ()
+    ((expect-task-clauses loop)
+     '())
+    ((expect-task-clauses loop (task aclause ...) clause ...)
+     (append (cons task (expect-action-clauses loop aclause ...))
+	     (expect-task-clauses loop clause ...)))))
+
+(define-syntax expect
+  (syntax-rules ()
+    ((expect name (var-inits ...) eclause ...)
+     (let name (var-inits ...)
+       (expect* (expect-options-clauses eclause ...)
+		(expect-task-clauses name eclause ...))))
+    ((expect (x ...) eclause ...)
+     (let loop ()
+       (expect* (expect-options-clauses loop (x ...) eclause ...)
+		(expect-task-clauses loop (x ...) eclause ...))))))

scheme/packages.scm

@@ -25,14 +25,14 @@
 	  spawn* (spawn :syntax)
 	  tsend tsend/cr
 	  (expect :syntax)
+	  expect*
 
 	  interact* interact/char*
 	  (interact :syntax))
-  (for-syntax (open expect-syntax-support scheme))
+  (for-syntax (open scheme-with-scsh))
 
   (open scheme-with-scsh formats structure-refs let-opt
 	receiving srfi-9 srfi-13 srfi-1)
-  (access signals) ; for ERROR
 
   (files expect interact))