- 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)
|
||||
(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
|
||||
(export task? make-task
|
||||
task:process
|
||||
|
|
@ -27,25 +20,21 @@
|
|||
(expect :syntax)
|
||||
expect*
|
||||
|
||||
interact* interact/char*
|
||||
(interact :syntax))
|
||||
(for-syntax (open scheme-with-scsh))
|
||||
interact*
|
||||
(interact :syntax)
|
||||
|
||||
(open scheme-with-scsh formats structure-refs let-opt
|
||||
receiving srfi-9 srfi-13 srfi-1)
|
||||
|
||||
(files expect interact))
|
||||
|
||||
(define-structure chat
|
||||
(export chat-abort chat-timeout chat-monitor
|
||||
chat-abort chat-timeout chat-monitor
|
||||
port->chat-logger file->chat-logger
|
||||
(look-for :syntax)
|
||||
(chat :syntax)
|
||||
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
|
||||
(export printf sprintf display/cr display/nl)
|
||||
|
|
|
|||
Loading…
Reference in New Issue