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)))))))