From 571e979360d6948e16f7b9864aa4c29d111fdf04 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Tue, 31 Aug 2004 10:16:54 +0000
Subject: [PATCH] - cleaned up expect-1* a bit - fixed a bug in the expect and
 expect-action-clause macros

---
 scheme/expect.scm | 205 +++++++++++++++++++++++-----------------------
 1 file changed, 101 insertions(+), 104 deletions(-)

diff --git a/scheme/expect.scm b/scheme/expect.scm
index 18aa27c..2cf9d30 100644
--- a/scheme/expect.scm
+++ b/scheme/expect.scm
@@ -229,107 +229,105 @@
   (set-task:buf! task
 		 (substring buffer (match:end m) (string-length buffer))))
 
+(define (handle-input task patterns input do-next monitor)
+  (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
+		     ;; Log all new data up to the match.
+		     (let* ((delta (- (string-length s)
+				      (string-length input)))
+			    (mend (- (match:end m 0) delta)))
+		       (monitor task (substring input 0 mend))
+		       (monitor task m)
+		       ;; Set the prematch buffer.
+		       (set-prematch task s 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)))))))))
+
+(define (handle-eof task patterns do-next monitor)
+  (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))))))))
+
+(define (handle-timeout monitor on-timeout)
+  (monitor #f 'timeout)
+  (on-timeout))
+
 (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
-			      ;; Log all new data up to the match.
-			      (let* ((delta (- (string-length s)
-					       (string-length input)))
-				     (mend (- (match:end m 0) delta)))
-				(monitor task (substring input 0 mend))
-				(monitor task m)
-				;; Set the prematch buffer.
-				(set-prematch task s 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)))))))))))))
+  ;; 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)))
+			    monitor)
+	      (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 monitor on-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)))
+						  monitor)
+				    (handle-eof task (cdr task-patterns)
+						(lambda ()
+						  (iloop (cdr inports)
+							 (cdr tasks-patterns-alist)
+							 remaining))
+						monitor)))
+			      (iloop (cdr inports)
+				     (cdr tasks-patterns-alist)
+				     (cons (car tasks-patterns-alist)
+					   remaining))))))))))))
 
 ;; Syntax based on procedural interface
 
@@ -377,11 +375,10 @@
 	   (expect-action-clauses clause ...)))
     ((expect-action-clauses (pattern () body ...) clause ...)
      (expect-action-clauses (pattern (ignore) body ...) clause ...))
-    ((expect-action-clauses (pattern (match mvars ...) body ...) clause ...)
+    ((expect-action-clauses (pattern (m mvars ...) body ...) clause ...)
      (cons (list 'match (lambda () pattern)
 		 (lambda (m)
-		   (let ((match m))
-		     (let-match m (mvars ...) body ...))))
+		   (let-match m (mvars ...) body ...)))
 	   (expect-action-clauses clause ...)))
     ((expect-action-clauses (else body ...) clause ...)
      (cons (list else (lambda () body ...))
@@ -405,8 +402,8 @@
   (syntax-rules ()
     ((expect (x ...) eclause ...)
      (let ((r (expect-clauses (x ...) eclause ...)))
-       (expect* (car r) (cdr r))))
+       (apply expect* (car r) (cdr r))))
     ((expect name (var-inits ...) eclause ...)
      (let name (var-inits ...)
        (let ((r (expect-clauses eclause ...)))
-	 (expect* (car r) (cdr r)))))))
+	 (apply expect* (car r) (cdr r)))))))