scsh-expect/scheme/expect-syntax.scm

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)))