289 lines
9.1 KiB
Scheme
289 lines
9.1 KiB
Scheme
;;; 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 ...)))))
|
|
|
|
|
|
(define (filter pred lis)
|
|
(if (pair? lis)
|
|
(let ((x (car lis)))
|
|
(if (pred x) (cons x (filter pred (cdr lis)))
|
|
(filter pred (cdr lis))))
|
|
'()))
|
|
|
|
(define (partition pred lis)
|
|
(if (pair? lis)
|
|
(let ((x (car lis)))
|
|
(receive (ins outs) (partition pred (cdr lis))
|
|
(if (pred x)
|
|
(values (cons x ins) outs)
|
|
(values ins (cons x outs)))))
|
|
(values '() '())))
|
|
|
|
;;; 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)))
|