- cleaned up expect-1* a bit

- fixed a bug in the expect and expect-action-clause macros

scheme/expect.scm

@@ -229,10 +229,7 @@
   (set-task:buf! task
 		 (substring buffer (match:end m) (string-length buffer))))
 
-(define (expect-1* on-timeout monitor timeout echo max-size
+(define (handle-input task patterns input do-next monitor)
-		   tasks-patterns-alist)
-  (let ((handle-input
-	 (lambda (task patterns input do-next)
   (let ((s (task:buf task)))
     (let loop ((patterns patterns))
       (if (null? patterns)
@@ -260,10 +257,9 @@
 		     (loop (cdr patterns)))))
 	      ((else)
 	       ((cadr pattern)))
-		       (else (error "undefined pattern type" (car pattern)))
+	      (else (error "undefined pattern type" (car pattern)))))))))
-		       )))))))
+
-	(handle-eof
+(define (handle-eof task patterns do-next monitor)
-	 (lambda (task patterns do-next)
   (set-task:pre-match! task (task:buf task))
   (set-task:buf! task "")
   (monitor task #f)
@@ -274,13 +270,14 @@
 	  (case (car pattern)
 	    ((eof) ((cadr pattern)))
 	    ((match test else) (loop (cdr patterns)))
-		     (else (error "undefined pattern type" (car pattern)))
+	    (else (error "undefined pattern type" (car pattern))))))))
-		     ))))))
-	(handle-timeout
-	 (lambda ()
-	   (monitor #f 'timeout)
-	   (on-timeout))))
 
+(define (handle-timeout monitor on-timeout)
+  (monitor #f 'timeout)
+  (on-timeout))
+
+(define (expect-1* on-timeout monitor timeout echo max-size
+		   tasks-patterns-alist)
   ;; first check existing data in the buffers
   (let loop ((f-tasks-patterns-alist tasks-patterns-alist))
     (if (not (null? f-tasks-patterns-alist))
@@ -289,7 +286,8 @@
 	       (s (task:buf task)))
 	  (if (not (zero? (string-length s)))
 	      (handle-input task (cdr task-patterns) s
-			      (lambda () (loop (cdr f-tasks-patterns-alist))))
+			    (lambda () (loop (cdr f-tasks-patterns-alist)))
+			    monitor)
 	      (loop (cdr f-tasks-patterns-alist))))
 	
 	;; start looking for input, handle it and throw away those
@@ -302,7 +300,7 @@
 					     tasks-patterns-alist))))
 		;; what is this (time) thing in the original?
 		(if (not (in-select! ivec timeout))
-		      (handle-timeout)
+		    (handle-timeout monitor on-timeout)
 		    (let iloop ((inports (vector->list ivec))
 				(tasks-patterns-alist tasks-patterns-alist)
 				(remaining '()))
@@ -313,23 +311,23 @@
 				     (task (car task-patterns))
 				     (s (do-input task)))
 				(if s
-				      (handle-input
+				    (handle-input task (cdr task-patterns) s
-				       task (cdr task-patterns) s
 						  (lambda ()
 						    (iloop (cdr inports)
 							   (cdr tasks-patterns-alist)
 							   (cons task-patterns
-						      remaining))))
+								 remaining)))
-				      (handle-eof
+						  monitor)
-				       task (cdr task-patterns)
+				    (handle-eof task (cdr task-patterns)
 						(lambda ()
 						  (iloop (cdr inports)
 							 (cdr tasks-patterns-alist)
-						remaining)))))
+							 remaining))
+						monitor)))
 			      (iloop (cdr inports)
 				     (cdr tasks-patterns-alist)
 				     (cons (car tasks-patterns-alist)
-					     remaining)))))))))))))
+					   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)))))))