- removed obsolete expect-syntax.scm
- incorporated chat into the expect package
This commit is contained in:
frese
parent
f327192879
commit
adbb0856af
|
|
@ -1,272 +0,0 @@
|
||||||
;;; The EXPECT macro expander
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(define syntax-error (structure-ref signals error))
|
|
||||||
|
|
||||||
;;; LET*, except that you can use multiple-value expressions in the binding
|
|
||||||
;;; forms. MLET = "M ultiple-value LET." I use this to keep the very long
|
|
||||||
;;; expect-expander code from drifting off the right side of the screen.
|
|
||||||
|
|
||||||
(define-syntax mlet
|
|
||||||
(syntax-rules ()
|
|
||||||
((mlet () body ...) (begin body ...))
|
|
||||||
|
|
||||||
;; Hack -- If a clause binds 0 vals, we *ignore* its return vals.
|
|
||||||
;; We don't require it to return exactly 0 vals.
|
|
||||||
((mlet ((() exp) init ...) body ...)
|
|
||||||
(begin exp (mlet (init ...) body ...)))
|
|
||||||
|
|
||||||
((mlet (((v ...) exp) init ...) body ...)
|
|
||||||
(receive (v ...) exp
|
|
||||||
(mlet (init ...) body ...)))
|
|
||||||
|
|
||||||
((mlet ((v exp) init ...) body ...)
|
|
||||||
(let ((v exp)) (mlet (init ...) body ...)))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; This is a hairy mother. If you ever try to read it or change it, you are
|
|
||||||
;;; advised to first try expanding a couple of toy examples and looking at the
|
|
||||||
;;; output to get a feel for the basic compilation strategy.
|
|
||||||
|
|
||||||
(define (expand-expect exp r c)
|
|
||||||
(mlet (((exp-name loop-var-inits clauses) ; Parse out the loop name
|
|
||||||
(if (and (<= 3 (length exp)) ; and var inits, if any.
|
|
||||||
(not (pair? (cadr exp))))
|
|
||||||
(values (cadr exp) (caddr exp) (cdddr exp)) ; Yep.
|
|
||||||
(values #f '() (cdr exp)))) ; Nope.
|
|
||||||
|
|
||||||
;; Parse the clauses into task clauses, a list of options,
|
|
||||||
;; and 0 or 1 on-timeout clauses.
|
|
||||||
((task-clauses options timeout-clauses)
|
|
||||||
(let recur ((clauses clauses))
|
|
||||||
(if (pair? clauses)
|
|
||||||
(let ((clause (car clauses)))
|
|
||||||
(receive (t o to) (recur (cdr clauses))
|
|
||||||
(cond ((not (pair? clause))
|
|
||||||
(syntax-error "Bad EXPECT clause" clause))
|
|
||||||
|
|
||||||
((c (car clause) (r 'option))
|
|
||||||
(values t (append (cdr clause) o) to))
|
|
||||||
|
|
||||||
((c (car clause) (r 'on-timeout))
|
|
||||||
(if (null? to)
|
|
||||||
(values t o (cons (cdr clause) to))
|
|
||||||
(syntax-error "Too many ON-TIMEOUT clauses in EXPECT" exp)))
|
|
||||||
|
|
||||||
;; It's a task clause.
|
|
||||||
(else (values (cons clause t) o to)))))
|
|
||||||
|
|
||||||
(values '() '() '()))))
|
|
||||||
|
|
||||||
;; Parse each task clause into three parts: the task expression, the
|
|
||||||
;; pattern/action aclauses, and 0 or 1 ON-EOF aclauses.
|
|
||||||
((tasks pa-clauses-list eof-clauses)
|
|
||||||
(let recur ((clauses task-clauses))
|
|
||||||
(if (pair? clauses)
|
|
||||||
(let* ((clause (car clauses))
|
|
||||||
(task (car clause))
|
|
||||||
(aclauses (cdr clause)))
|
|
||||||
(receive (tasks pas eofs) (recur (cdr clauses))
|
|
||||||
(receive (this-tasks-eofs this-tasks-pas)
|
|
||||||
(partition (lambda (ac)
|
|
||||||
(if (pair? ac)
|
|
||||||
(c (car ac) (r 'on-eof))
|
|
||||||
(syntax-error "Bad action clause in EXPECT"
|
|
||||||
clause ac)))
|
|
||||||
aclauses)
|
|
||||||
(if (> (length this-tasks-eofs) 1)
|
|
||||||
(syntax-error "Too many ON-EOF action clauses in EXPECT"
|
|
||||||
clause)
|
|
||||||
(values (cons task tasks)
|
|
||||||
(cons this-tasks-pas pas)
|
|
||||||
(cons this-tasks-eofs eofs))))))
|
|
||||||
(values '() '() '()))))
|
|
||||||
|
|
||||||
(%vector (r 'vector)) ; Bind a mess of syntax
|
|
||||||
(%lambda (r 'lambda))
|
|
||||||
(%let (r 'let))
|
|
||||||
(%let* (r 'let*))
|
|
||||||
(%letrec (r 'letrec))
|
|
||||||
(%begin (r 'begin))
|
|
||||||
(%and (r 'and))
|
|
||||||
(%string-match (r 'string-match))
|
|
||||||
(%vector (r 'vector))
|
|
||||||
(%let-match (r 'let-match))
|
|
||||||
(%s (r 's))
|
|
||||||
(%i (r 'i))
|
|
||||||
(%m (r 'm))
|
|
||||||
(%monitor (r 'mon))
|
|
||||||
(%do-next (r 'do-next))
|
|
||||||
(%do-match-hacking (r 'do-match-hacking))
|
|
||||||
(%do-select (r 'do-select))
|
|
||||||
(%=> (r '=>))
|
|
||||||
(%test (r 'test))
|
|
||||||
(%else (r 'else))
|
|
||||||
(%cond (r 'cond))
|
|
||||||
(%try-task (r 'try-task))
|
|
||||||
(%task:buf (r 'task:buf))
|
|
||||||
(%task:in (r 'task:in))
|
|
||||||
(%set-prematch (r 'set-prematch))
|
|
||||||
(%first-try (r 'first-try))
|
|
||||||
(%time (r 'time))
|
|
||||||
(%receive (r 'receive))
|
|
||||||
(%select! (r 'select!))
|
|
||||||
(%if (r 'if))
|
|
||||||
(%- (r '-))
|
|
||||||
(%+ (r '+))
|
|
||||||
(%> (r '>))
|
|
||||||
|
|
||||||
;; Now we need a bunch of label names. Task clause #3 needs
|
|
||||||
;; try-task3, task3, try-match3, and maybe do-eof3 (if it has
|
|
||||||
;; an ON-EOF action clause)
|
|
||||||
(task-indices (let recur ((tclauses task-clauses) (i 0))
|
|
||||||
(if (pair? tclauses)
|
|
||||||
(cons i (recur (cdr tclauses) (+ i 1)))
|
|
||||||
'())))
|
|
||||||
(vari (lambda (s i)
|
|
||||||
(r (string->symbol (string-append s (number->string i))))))
|
|
||||||
(try-task-vars (map (lambda (i) (vari "try-task" i)) task-indices))
|
|
||||||
(task-vars (map (lambda (i) (vari "task" i)) task-indices))
|
|
||||||
(try-match-vars (map (lambda (i) (vari "try-match" i)) task-indices))
|
|
||||||
(do-eof-vars (map (lambda (i maybe-eof-clause)
|
|
||||||
;; #F if the tclause doesn't have an ON-EOF aclause.
|
|
||||||
(and (pair? maybe-eof-clause)
|
|
||||||
(vari "do-eof" i)))
|
|
||||||
task-indices eof-clauses))
|
|
||||||
|
|
||||||
;; do-next[i] is the proc task I should call to
|
|
||||||
;; do the next thing.
|
|
||||||
(do-nexts (append (cdr try-task-vars)
|
|
||||||
(list %do-select)))
|
|
||||||
|
|
||||||
;; Build a bunch of LET bindings.
|
|
||||||
;; First, evaluate and bind all the tasks.
|
|
||||||
(task-bindings (map list task-vars tasks))
|
|
||||||
|
|
||||||
;; Bind IVEC to the task vector.
|
|
||||||
(ivec (r 'ivec))
|
|
||||||
(ivec-binding `(,ivec (,%vector ,@(map (lambda (tv) `(,%task:in ,tv))
|
|
||||||
task-vars))))
|
|
||||||
|
|
||||||
;; Build a bunch of LETREC bindings.
|
|
||||||
;; First, the do-eof bindings.
|
|
||||||
(do-eofs1 (map (lambda (label bodies) ; (length BODIES) < 2.
|
|
||||||
(and (pair? bodies)
|
|
||||||
`(,label (,%lambda () . ,(cdar bodies)))))
|
|
||||||
do-eof-vars eof-clauses))
|
|
||||||
(do-eofs (filter (lambda (x) x) do-eofs1))
|
|
||||||
|
|
||||||
;; Second, the try-matchI bindings.
|
|
||||||
(pa->cond-clause (lambda (pa-clause task)
|
|
||||||
(if (c (car pa-clause) %test)
|
|
||||||
(cdr pa-clause)
|
|
||||||
`((,%string-match ,(car pa-clause) ,%s) ,%=>
|
|
||||||
(,%lambda (,%m)
|
|
||||||
(,%do-match-hacking ,task ,%m ,%s ,%i ,%monitor)
|
|
||||||
(,%let-match ,%m . ,(cdr pa-clause)))))))
|
|
||||||
|
|
||||||
(try-matcher (lambda (pa-clauses task)
|
|
||||||
`(,%lambda (,%s ,%i ,%do-next)
|
|
||||||
(,%cond ,@(map (lambda (pa)
|
|
||||||
(pa->cond-clause pa task))
|
|
||||||
pa-clauses)
|
|
||||||
(,%else (,%monitor ,task ,%i)
|
|
||||||
(,%do-next))))))
|
|
||||||
|
|
||||||
(try-matches (map (lambda (label task pa-clauses)
|
|
||||||
`(,label ,(try-matcher pa-clauses task)))
|
|
||||||
try-match-vars
|
|
||||||
task-vars
|
|
||||||
pa-clauses-list))
|
|
||||||
|
|
||||||
;; Third, the try-taskI bindings
|
|
||||||
(try-tasks (map (lambda (label task i match-tryer
|
|
||||||
do-next do-eof)
|
|
||||||
`(,label (,%lambda ()
|
|
||||||
(,%try-task ,ivec ,i ,task ,match-tryer
|
|
||||||
,do-next
|
|
||||||
,(or do-eof do-next)
|
|
||||||
,%monitor))))
|
|
||||||
|
|
||||||
try-task-vars task-vars task-indices
|
|
||||||
try-match-vars do-nexts do-eof-vars))
|
|
||||||
|
|
||||||
|
|
||||||
;; When EXPECT starts, there may be leftover data sitting in
|
|
||||||
;; the task buffers from a previous EXPECT execution (too bad
|
|
||||||
;; we don't have infinite push-back ports). So we have to run
|
|
||||||
;; all the pattern/action match code before doing the select
|
|
||||||
;; call, or trying to do input. This expression is the code
|
|
||||||
;; that does this. If there *isn't* any saved-up input in a
|
|
||||||
;; task's push-back buffer, we don't call the task's try-match
|
|
||||||
;; proc.
|
|
||||||
(initial-trymatch
|
|
||||||
(let recur ((try-matchers try-match-vars)
|
|
||||||
(tasks task-vars))
|
|
||||||
(if (pair? try-matchers)
|
|
||||||
(let ((try-match (car try-matchers))
|
|
||||||
(try-matchers (cdr try-matchers))
|
|
||||||
(task (car tasks))
|
|
||||||
(tasks (cdr tasks)))
|
|
||||||
`(,%first-try ,task ,try-match
|
|
||||||
(,%lambda () ,(recur try-matchers tasks))))
|
|
||||||
`(,%do-select))))
|
|
||||||
|
|
||||||
;; Parse the options
|
|
||||||
((timeout-secs mon-exp)
|
|
||||||
(let lp ((timeout-secs 10) (mon-exp (r 'null-monitor))
|
|
||||||
(opts options))
|
|
||||||
(if (pair? opts)
|
|
||||||
(let ((opt (car opts))
|
|
||||||
(opts (cdr opts)))
|
|
||||||
(if (or (not (pair? opt))
|
|
||||||
(not (= (length opt) 2)))
|
|
||||||
(syntax-error "Illegal EXPECT option" opt))
|
|
||||||
(let ((kw (car opt)))
|
|
||||||
(cond ((c kw (r 'timeout))
|
|
||||||
(lp (cadr opt) mon-exp opts))
|
|
||||||
((c kw (r 'monitor))
|
|
||||||
(lp timeout-secs (cadr opt) opts))
|
|
||||||
(else (syntax-error "Illegal EXPECT option" opt)))))
|
|
||||||
(values timeout-secs mon-exp))))
|
|
||||||
|
|
||||||
;; Build the select code.
|
|
||||||
;; The TIME-DONE var is bound to "what time we time out",
|
|
||||||
;; not "how many seconds until we time out."
|
|
||||||
(timeout-var (and timeout-secs (r 'time-done)))
|
|
||||||
(loop-top `(,%lambda ()
|
|
||||||
(,%receive (in out ex)
|
|
||||||
(,%select! ,ivec '#() '#()
|
|
||||||
,@(if timeout-var
|
|
||||||
`((,%and ,timeout-var
|
|
||||||
(,%- ,timeout-var (,%time))))
|
|
||||||
'()))
|
|
||||||
(,%if (,%> in 0)
|
|
||||||
(,(car try-task-vars))
|
|
||||||
,(if (pair? timeout-clauses)
|
|
||||||
`(,%begin ,@(car timeout-clauses))
|
|
||||||
''timeout)))))
|
|
||||||
|
|
||||||
;; This is the core letrec -- the wait-for-input &
|
|
||||||
;; try-to-match loop.
|
|
||||||
(inner-loop `(,%letrec (,@do-eofs
|
|
||||||
,@try-matches
|
|
||||||
,@try-tasks
|
|
||||||
(,%do-select ,loop-top))
|
|
||||||
,initial-trymatch))
|
|
||||||
|
|
||||||
;; This is the outer, named loop (if any).
|
|
||||||
(named-loop (if exp-name
|
|
||||||
`(,%let ,exp-name ,loop-var-inits
|
|
||||||
,inner-loop)
|
|
||||||
inner-loop)))
|
|
||||||
|
|
||||||
;; Build the final expression.
|
|
||||||
`(,%let* (,@task-bindings
|
|
||||||
,ivec-binding
|
|
||||||
(,%monitor ,mon-exp)
|
|
||||||
,@(if timeout-var
|
|
||||||
`((,timeout-var ,timeout-secs)
|
|
||||||
(,timeout-var (,%and ,timeout-var
|
|
||||||
(,%+ (,%time) ,timeout-var))))
|
|
||||||
'())) ; No timeout-var binding needed.
|
|
||||||
,named-loop)))
|
|
||||||
|
|
@ -3,13 +3,6 @@
|
||||||
(open scheme-with-scsh let-opt)
|
(open scheme-with-scsh let-opt)
|
||||||
(files tty-utils))
|
(files tty-utils))
|
||||||
|
|
||||||
(define-structure expect-syntax-support
|
|
||||||
(export expand-expect)
|
|
||||||
(open scheme structure-refs srfi-1
|
|
||||||
receiving) ; for making alien containers.
|
|
||||||
(access signals) ; for ERROR
|
|
||||||
(files expect-syntax))
|
|
||||||
|
|
||||||
(define-structure expect
|
(define-structure expect
|
||||||
(export task? make-task
|
(export task? make-task
|
||||||
task:process
|
task:process
|
||||||
|
|
@ -27,25 +20,21 @@
|
||||||
(expect :syntax)
|
(expect :syntax)
|
||||||
expect*
|
expect*
|
||||||
|
|
||||||
interact* interact/char*
|
interact*
|
||||||
(interact :syntax))
|
(interact :syntax)
|
||||||
(for-syntax (open scheme-with-scsh))
|
|
||||||
|
|
||||||
(open scheme-with-scsh formats structure-refs let-opt
|
chat-abort chat-timeout chat-monitor
|
||||||
receiving srfi-9 srfi-13 srfi-1)
|
|
||||||
|
|
||||||
(files expect interact))
|
|
||||||
|
|
||||||
(define-structure chat
|
|
||||||
(export chat-abort chat-timeout chat-monitor
|
|
||||||
port->chat-logger file->chat-logger
|
port->chat-logger file->chat-logger
|
||||||
(look-for :syntax)
|
(look-for :syntax)
|
||||||
(chat :syntax)
|
(chat :syntax)
|
||||||
send send/cr)
|
send send/cr)
|
||||||
|
(for-syntax (open scheme-with-scsh))
|
||||||
|
|
||||||
(open scheme-with-scsh expect fluids)
|
(open scheme-with-scsh formats structure-refs let-opt
|
||||||
|
receiving srfi-9 srfi-13 srfi-1 srfi-11
|
||||||
|
tty-utils fluids)
|
||||||
|
|
||||||
(files chat))
|
(files expect interact chat))
|
||||||
|
|
||||||
(define-structure printf-package
|
(define-structure printf-package
|
||||||
(export printf sprintf display/cr display/nl)
|
(export printf sprintf display/cr display/nl)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue