diff --git a/scheme/expect.scm b/scheme/expect.scm index ee2fa9c..9aeeff6 100644 --- a/scheme/expect.scm +++ b/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 ...)))))) diff --git a/scheme/packages.scm b/scheme/packages.scm index cc5a295..386ae2e 100644 --- a/scheme/packages.scm +++ b/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))