- cleaned up expect-1* a bit
- fixed a bug in the expect and expect-action-clause macros
This commit is contained in:
frese
parent
c608b585a5
commit
571e979360
|
|
@ -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)))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue