From 5be06d74819e09b697d8e6ac7bf994f64b5420e5 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Thu, 15 Jul 2004 17:34:52 +0000
Subject: [PATCH] *** empty log message ***

---
 COPYING                  |   2 +
 README                   |   2 +
 doc/chat.doc             |  15 ++
 doc/expect.doc           | 166 ++++++++++++++++++++++
 scheme/chat.scm          | 165 ++++++++++++++++++++++
 scheme/expect-syntax.scm | 288 +++++++++++++++++++++++++++++++++++++++
 scheme/expect.scm        | 267 ++++++++++++++++++++++++++++++++++++
 scheme/let-match.scm     |  99 ++++++++++++++
 scheme/packages.scm      |  74 ++++++++++
 9 files changed, 1078 insertions(+)
 create mode 100644 COPYING
 create mode 100644 README
 create mode 100644 doc/chat.doc
 create mode 100644 doc/expect.doc
 create mode 100644 scheme/chat.scm
 create mode 100644 scheme/expect-syntax.scm
 create mode 100644 scheme/expect.scm
 create mode 100644 scheme/let-match.scm
 create mode 100644 scheme/packages.scm
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..1976793
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,2 @@
+Designed and implemented by David Fisher and Olin Shivers.
+Copyright (C) 1998 by the Scheme Underground.
diff --git a/README b/README
new file mode 100644
index 0000000..1976793
--- /dev/null
+++ b/README
@@ -0,0 +1,2 @@
+Designed and implemented by David Fisher and Olin Shivers.
+Copyright (C) 1998 by the Scheme Underground.
diff --git a/doc/chat.doc b/doc/chat.doc
new file mode 100644
index 0000000..0d100de
--- /dev/null
+++ b/doc/chat.doc
@@ -0,0 +1,15 @@
+(chat <task> <body> ...)
+
+dynvars: $task $chat-cont $chat-abort-re $chat-timeout
+
+(look-for* re [on-timeout])
+(look-for re [on-timeout ...])
+
+(send fmt arg ...)
+(send/cr fmt arg ...)
+
+logging output funs?
+
+side-effecting option setting
+    (chat-abort <re>)
+    (chat-timeout <nsecs>)
diff --git a/doc/expect.doc b/doc/expect.doc
new file mode 100644
index 0000000..ab5b7f4
--- /dev/null
+++ b/doc/expect.doc
@@ -0,0 +1,166 @@
+The Scheme Underground Expect package
+Designed and implemented by David Fisher and Olin Shivers
+
+(spawn* THUNK) -> task						procedure
+
+Spawn* forks a process to execute THUNK, and returns a task data-structure
+that contains all of the information that expect-package elements need in
+order to interact with that process.
+
+(spawn . EPF) -> task						procedure
+
+This is syntactic sugar for (spawn* (lambda () (exec-epf EPF))).
+Spawns the epf.
+
+(ports->task INPUT-PORT OUTPUT-PORT) -> task			procedure
+
+This procedure constructs a task from a pair of ports.
+
+(task:in TASK) -> output-port					procedure
+(task:out TASK) -> input-port					procedure
+(task:process TASK) -> process					procedure
+
+These three procedures return, in order, the input port that can be used to
+get data from the task, the output port that can be used to send data to the
+task, and the process that the task is running.
+
+(task:pre-match TASK) -> string					procedure
+(task:buf TASK) -> string					procedure
+
+When an EXPECT pattern matches some input, the task:pre-match field is set to
+the string preceding the matched data, and the task:buf field is set to the
+string coming after the matched data, that is, it saves input that hasn't
+yet been processed. When EXPECT starts, it first considers any data stored
+in the task:buf field.
+
+(set-task:pre-match TASK STR)
+(set-task:buf TASK STR)
+...
+
+-------------------------------------------------------------------------------
+(EXPECT [<name> <loop-var-inits>] <eclause> ...) -> values		syntax
+
+<eclause> ::= (<task> <aclause> ...)		    [Task clause.]
+	  |   <option-clause>
+          |   (ON-TIMEOUT <body> ...)		    [Do on timeout.]
+
+Action clauses:
+<aclause> ::= (ON-EOF <body> ...)		    [Do on EOF.]
+          |   (<pattern> <matchvars> <exp> ...)	    [Do if pattern matches.]
+	  |   (TEST . <cond-clause>)
+
+<matchvars> ::= () 				    [No match info]
+            |   (<matchvar>)			    [Match struct only]
+            |   (<matchvar> <submatch-var0> ...)    [...also submatch strings.]
+
+<option-clause> ::= (OPTION <option> ...)
+<option> ::= (TIMEOUT <nsecs>) 
+         |   (ECHO <bool>)		; Not supported
+         |   (MAX-SIZE <nchars>)	; Not supported
+	 |   (MONITOR <proc>)
+
+Expect takes a number of tasks, and waits for a number of patterns to
+be output by these tasks.  When expect sees a pattern for which it has been
+waiting, it executes the appropriate list of commands.  The two types of
+expect clauses are option clauses and task-pattern clauses.
+
+Option clauses take the form (OPTION <option> ...)
+where an <option> is one of
+  (TIMEOUT <nsecs>)   This controls how long expect waits for the patterns
+	              before timing out.  The lowest timeout clause
+		      determines when the entire expect form will time out.
+		      A timeout value of #f means no timeout. The default
+		      value is ... seconds.
+
+  (MONITOR <proc>)    This hook establishes a monitor procedure for the
+		      the expect processing. A monitor is a procedure
+		      of one argument, that is applied when various
+		      events occur:
+			#F	 EOF
+			regexp	 Match occurred.
+			string	 New input arrived.
+				 This string will not span a match.
+				 That is, if new input arrives and
+				 is matched, then we only report the
+				 new input up to the end of the match.
+				 The rest of the input is saved in the
+				 task's push-back buffer and is not reported.
+			'timeout EXPECT timed out.
+
+An action clause <aclause> can be one of
+  (<pattern> <matchvars> <body> ...)
+	If the pattern matches input read from the task, expect binds the
+	match vars and then executes the body forms.  The value of the whole
+	EXPECT form is the value produced by the last body form. The match
+	vars list is of the form
+	    ([<match-var> [<sub-match-var0> ... <sub-match-varN>]])
+	<match-var> is bound to the regexp match structure. <sub-match-varI>
+	is bound to the string corresponding to the regexp's Ith sub-match
+	(where sub-match 0 is the string for the whole match). Any of these
+	variables may be #F instead of an identifier, meaning a "don't-care"
+	binding.
+
+  (on-eof EXPRESSION ...)
+	If EXPECT hits EOF on the task without finding a match, this clause
+	is triggered. If EXPECT hits EOF and there is no ON-EOF clause for
+        the task, nothing happens.
+
+  (test . COND-CLAUSE)
+	This allows for general conditionals to be placed into the
+	EXPECT form.
+
+-------------------------------------------------------------------------------
+(INTERACT <task> <iclause> ...)						syntax
+
+Interact allows the user to interact with a running task, relaying the
+keys pressed by the user to the task and outputting the characters
+provided by the task to the user.  If clauses are provided by the
+programmer, interact will filter input before passing it along to the
+task.  A clause is either a character-clause or a filter-clause.
+	
+(<character> <continuation-variable> <body> ...)
+    When interact matches the character, it bind the continuation variable
+    to the continuation out of the interaction, then evaluates the clause
+    body.
+
+(FILTER <procedure>)
+    Where filter is passed two variables, the character input and the
+    continuation out of the interaction.  In both cases, if the clause
+    returns true, it falls through to the next clause.  If all clauses
+    fall through, the character is passed on to the task.  However, the
+    continuation still needs to be called in order to break out of the
+    interaction.
+
+    Example: (filter (lambda (c k)
+                       (if 
+
+(send STRING TASK) -> (undefined)				procedure
+
+Send sends the string to the task, as if a user had typed it.
+
+(close-task TASK) -> (undefined)				procedure
+
+Close-task closes all input and output ports corresponding to the indicated
+task.
+
+(wait-task TASK) -> (undefined)					procedure
+
+Wait-task waits for the indicated task to complete, reaping the task.
+
+-------------------------------------------------------------------------------
+Tty-Mung Package
+
+(modify-tty-info PROC [PORT])					procedure
+
+Modify-tty-info applies PROC to either the tty-info of the current
+input port, or the indicated PORT, changing the state of the terminal.
+There are five procedures provided to use with modify-tty-info:
+
+echo-off	Turns terminal echoing off.
+echo-on		Turns terminal echoing on.
+raw		Puts the terminal into raw mode.  Raw-initialize _must_
+		be used after raw for it to work right.
+raw-initialize	Initializes the min and time fields of a raw terminal.
+canonical	Puts the terminal into raw mode.
+
+
diff --git a/scheme/chat.scm b/scheme/chat.scm
new file mode 100644
index 0000000..0db7c23
--- /dev/null
+++ b/scheme/chat.scm
@@ -0,0 +1,165 @@
+;;; Chat for scsh.
+;;; Designed and implemented by David Fisher and Olin Shivers.
+;;; Copyright (C) 1998 by the Scheme Underground.
+
+;;; $chat-task $chat-cont $chat-abort-re $chat-timeout $chat-monitor
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These are the fluid vars bound by CHAT.
+
+(define $chat-task (make-fluid #f))	; I/O task 
+
+(define $chat-cont (make-fluid #f))	; Continuation used to abort the CHAT
+
+(define $chat-monitor (make-fluid #f))
+
+;;; This is my lame approximation to a regexp that matches nothing.
+;;; It will never match a non-empty string, in any event, and that's
+;;; good enough for this app.
+(define default-chat-abort-re (make-regexp "^$"))
+
+;;; Regexp that causes any LOOK-FOR clause to abort out of the CHAT.
+(define $chat-abort-re (make-fluid default-chat-abort-re))
+
+(define (chat-abort re)      (set-fluid! $chat-abort-re (->regexp re)))
+
+;;; Number of seconds a LOOK-FOR clause should wait before timing out.
+(define $chat-timeout (make-fluid 45))
+
+;;; These guys override the defaults.
+(define (chat-timeout nsecs) (set-fluid! $chat-timeout nsecs))
+(define (chat-monitor cmon) (set-fluid! $chat-monitor cmon))
+
+(define-syntax define-simple-syntax
+  (syntax-rules ()
+    ((define-simple-syntax (name . pattern) result)
+     (define-syntax name (syntax-rules () ((name . pattern) result))))))
+
+(define-simple-syntax (chat task exp ...)
+  (chat* task (lambda () exp ...)))
+
+(define (chat* task thunk)
+  (call-with-current-continuation
+    (lambda (k)
+      (let-fluids $chat-task       task
+		  $chat-abort-re   default-chat-abort-re
+		  $chat-cont       k
+		  $chat-timeout	   45
+		  $chat-monitor	   #f
+        (lambda ()
+	  (with-current-output-port (task:out task)
+	    (with-current-input-port (task:in task)
+              (thunk))))))))
+
+(define (look-for* re . maybe-on-timeout)
+  (let ((tmout     (fluid $chat-timeout))
+	(chat-cont (fluid $chat-cont))
+	(task      (fluid $chat-task))
+	(abort-re  (fluid $chat-abort-re))
+	(cmon  (fluid $chat-monitor)))
+    (if cmon (cmon 'looking-for re))
+    (expect (option (timeout tmout)	; Timeout in $chat-timeout secs.
+		    (monitor (if cmon
+				 (chat->expect-monitor cmon)
+				 (lambda (task event) #f))))	; No-op
+
+	    ;; Expect triggers the monitor for us on timeout.
+	    (on-timeout (if (pair? maybe-on-timeout)	; Timeout =>
+			    ((car maybe-on-timeout))	;   Call handler or
+			    (chat-cont 'timeout))) 	;   abort.
+
+	    (task (re (m) 			; See RE => return false.
+		    (if cmon (cmon 'found m))
+		    #f)
+		  (abort-re (#f s)		; See $chat-abort-re =>
+		    (if cmon (cmon 'abort #f))	;   abort & return the
+		    (chat-cont s))		;   abort string.
+
+		  (on-eof
+		   ;; EXPECT triggers the monitor for us.
+		   (chat-cont 'eof))))))
+
+(define-syntax look-for
+  (syntax-rules ()
+    ((look-for re) (look-for* re))
+    ((look-for re on-timeout ...)
+     (look-for* re (lambda () on-timeout ...)))))
+
+;;; chat-logger monitors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Monitors are called on the following events:
+;;; - looking-for(re)
+;;; - found(match)
+;;; - new-input(text)
+;;; - sending(text)
+;;; - abort
+;;; - eof
+;;; - timeout
+
+;;; Builds a chat monitor from an expect monitor.
+;;; We do nothing with match events, because it's ambiguous --
+;;; we might have matched what the user was looking for, or we might
+;;; have matched the abort pattern. So chat puts the chat monitor calls
+;;; directly in the EXPECT form.
+(define (chat->expect-monitor cmon)
+  (lambda (task event)
+    (cond ((not event)		 (cmon 'eof #f))
+	  ((string? event)	 (cmon 'new-input event))
+	  ((regexp-match? event))	; Do nothing
+	  ((eq? 'timeout event)  (cmon 'timeout #f))
+	  (else (error "Unknown EXPECT event" task event)))))
+
+(define (port->chat-logger port)
+  (lambda (event val)
+    (case event
+      ((looking-for)	(format port "expect(~a)\n" val))
+      ((found)		(write-string "-- got it\n" port))
+      ((new-input)	(format port "[~a]" val))
+      ((sending)	(format port "send(~a)\n" val))
+      ((eof)		(write-string "EOF encountered.\n" port))
+      ((timeout)	(write-string "-- timed out. \n" port))
+      ((abort)		(write-string "-- aborting. \n" port))
+      (else		(format port "Unknown chat event: ~a ~a\n" event val)))
+    (force-output port)))
+
+
+(define (file->chat-logger fname . maybe-open-flags)
+  (port->chat-logger (apply open-output-file fname maybe-open-flags)))
+
+;;; Monitor-aware I/O procedures
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Outputs to (CURRENT-OUTPUT-PORT) 
+;;; and also triggers the current chat monitor.
+
+(define (send fmt . args)
+  (cond ((fluid $chat-monitor) =>
+	 (lambda (cm)
+	   (let ((s (apply format #f fmt args)))
+	     (cm 'sending s)
+	     (write-string s))))
+	(else (apply format (current-output-port) fmt args))))
+
+(define (send/cr fmt . args)
+  (cond ((fluid $chat-monitor) =>
+	 (lambda (cm)
+	   (let ((s (string-append (apply format #f fmt args) "\r")))
+	     (cm 'sending s)
+	     (write-string s))))
+	(else (apply format (current-output-port) fmt args)
+	      (write-string "\r"))))
+
+
+;;;   (define (dialin modem phone-num username password)
+;;;     (chat modem
+;;;       (abort-pattern "BUSY|NO CARRIER|NO DIALTONE|ERROR")
+;;;       (send		"ATZ\r")	
+;;;       (look-for	"OK")
+;;;	  (send		"ATDT~a\r" phone-num)
+;;;       (look-for	"CONNECT")
+;;;       (look-for	"ogin:"
+;;;	      (send "\r")
+;;;	      (look-for "ogin:"))
+;;;	  (send/cr	username)
+;;;       (look-for	"assword:")
+;;;	  (send/cr	password)
+;;;       (look-for	"%")))
diff --git a/scheme/expect-syntax.scm b/scheme/expect-syntax.scm
new file mode 100644
index 0000000..fd294ce
--- /dev/null
+++ b/scheme/expect-syntax.scm
@@ -0,0 +1,288 @@
+;;; 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)))
diff --git a/scheme/expect.scm b/scheme/expect.scm
new file mode 100644
index 0000000..bd3e8c7
--- /dev/null
+++ b/scheme/expect.scm
@@ -0,0 +1,267 @@
+;;; Expect for scsh.
+;;; Designed and implemented by David Fisher and Olin Shivers.
+;;; Copyright (C) 1998 by the Scheme Underground.
+
+;;; Todo:
+;;; - Fairness & round-robin looping
+;;; - If all tasks eof, should we detect this and bail out early?
+;;; - I need a little toolkit for constructing monitors.
+
+;;; If I had infinite-pushback ports, I could flush the "task" structure
+;;; entirely. This would be better done with a transducer architecture.
+
+;;; Interact
+;;; - -nobuffer is useful for spotting stuff as it flies by.
+;;; - It can handle matching in both directions.
+;;; - It can handle strings and regexps.
+
+;;; This file contains the following Scheme 48 modules:
+;;; - expect-syntax-support
+;;;   This package must be opened in expect-package's FOR-SYNTAX package,
+;;;   so that the EXPECT macro-expander code can use its procedure.
+;;; - 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 task
+  process
+  in
+  out
+  (buf "")
+  (pre-match #f))	; Everything before the current match.
+
+(define (tsend task fmt . args)
+  (apply format (task:out task) fmt args))
+
+(define tsend-line 
+  (let ((cr (string-ref "\r" 0)))	; Ugh
+    (lambda (task fmt . args)
+      (let ((p (task:out task)))
+	(apply format p fmt args)
+	(write-char cr p)))))
+
+
+(define (user-task)
+  (ports->task (current-input-port) (current-output-port)))
+   
+
+;;; Spawn a process.
+
+(define (spawn* thunk)
+  (receive (process in out tty) (fork-pty-session thunk)
+    (set-port-buffering in bufpol/none)
+    (set-port-buffering out bufpol/none)
+    (make-task process in out)))
+
+(define-syntax spawn
+  (syntax-rules ()
+    ((spawn . epf)   (spawn* (lambda () (exec-epf . epf))))))
+      
+
+;;; Make a pseudo-task.
+
+(define (ports->task input-port output-port)
+  (set-port-buffering input-port  bufpol/none)
+  (set-port-buffering output-port bufpol/none)
+  (make-task #f input-port output-port))
+
+
+(define (file->task fname)
+  (let* ((iport (open-file fname open/read+write))
+	 (oport (dup->outport iport)))
+    (ports->task iport oport)))
+
+(define (close-task task)
+  (close (task:in task))
+  (close (task:out task)))
+
+;;;; Append info to a buffer without its going over the max size.
+;;;; As data is moved out of the match buffer, it is moved into
+;;;; the pre-match buffer.
+;;;;
+;;;; Ack, this is not too efficient. Need to change this whole style.
+;
+;(define (buf-append task str max-size)
+;    (let* ((buf (task:buf task))
+;	   (buf-size (string-length buf))
+;	   (str-size (string-length str))
+;	   (total-size (+ buf-size str-size)))
+;
+;      (cond ((<= total-size max-size)	; BUF := all of BUF + all of STR.
+;	     (string-append buf str))
+;
+;	    ;; BUF := some of BUF + all of STR.
+;	    ((<= str-size max-size)
+;	     (let ((i (- total-size max-size)))
+;	       (set-task:pre-match (string-append (task:pre-match task)
+;						  (substring buf 0 i)))
+;	       (string-append (substring buf i buf-size)
+;			      str)))
+;	    
+;	    ;; BUF := some of STR.
+;	    (else (let ((i (- str-size max-size)))
+;		    (set-task:pre-match (string-append (task:pre-match task)
+;						       buf
+;						       (substring str 0 i)))
+;		    (substring str i str-size))))))
+
+
+;;; We just matched M out of BUFFER. 
+;;; - Put everything in BUFFER *before* the match into (TASK:PRE-MATCH TASK). 
+;;; - Put everything in BUFFER *after* the match into (TASK:BUF TASK).
+
+(define (set-prematch task buffer m)
+  (set-task:pre-match task (substring buffer 0 (match:start m)))
+  (set-task:buf task
+		(substring buffer (match:end m) (string-length buffer))))
+
+
+;;; Slurp in data from port ivec[i] and add it to the task's buffer.
+;;; Return the new data (not the whole buffer).
+;;; If we get EOF instead, set ivec[i] to #f and return false. This is
+;;; really inefficient in space and time -- every time we get a little bit
+;;; of input, we copy and throw away the whole match buffer. Argh.
+
+(define (do-input task)
+  (let* ((port (task:in task))
+
+	 ;; If the read blows up, return #f. This is how tty's indicate 
+	 ;; to pty's they've been closed. Ugh.
+	 (s (with-errno-handler ((e p) ((errno/io) #f))
+	      (read-string/partial 256 port))))
+
+    (and s (let ((newbuf (string-append (task:buf task) s)))
+	     (set-task:buf task newbuf)
+	     s))))
+
+;;; A (<task> <aclause> ...) task-clause becomes the following chunk of code
+;;; that is executed after the select call on ivec[]. I is the index of
+;;; <task>'s input port in the port vector ivec:
+;;;
+;;; If ivec[i] is non-#f
+;;;   -- Select says there's input available.
+;;;   Get input from task
+;;;   If EOF
+;;;     ivec[i] := #f	(This task is now permanently out of the running.)
+;;;     If there's an ON-EOF clause, do it and quit.
+;;;     If no ON-EOF clause, go on to task i+1.
+;;;   else we got some data:
+;;;     Try out matches. On match, do the match action & we are done.
+;;;     If no match, go on to task i+1
+;;; 
+;;; If ivec[i] is #f
+;;;   -- No input available right now.
+;;;  ivec[i] := taski.in	(Put the input port back in the vector)
+;;;  go on to task i+1
+;;;
+;;; "go on to task i+i" means "loop back to the select call" when task i
+;;; is the last one.
+
+(define (try-task ivec i task try-match-clauses do-next do-eof monitor)
+  (if (vector-ref ivec i)
+
+      ;; Input is available (or EOF). Read it in.
+      ;; If we get some, try out the pattern/action clauses.
+      ;; If we get EOF, do the EOF action (which is the ON-EOF action clause,
+      ;; if there is one, or go on to the next task clause if there isn't).
+      (cond ((do-input task) =>
+	     (lambda (i) (try-match-clauses (task:buf task) i do-next)))
+	    (else
+	     (set-task:pre-match task (task:buf task))
+	     (set-task:buf task "")
+	     (monitor task #f) ; Signal EOF
+	     (do-eof)
+	     (vector-set! ivec i #f)))
+
+      ;; No input available for task i. Put it back in the select vector
+      ;; for next time, and go on to the next thing.
+      (begin (vector-set! ivec i (task:in task))
+	     (do-next))))
+
+
+;;; M is the match. S is the total string. I is the new data that just
+;;; arrived -- a non-empty suffix of S.
+(define (do-match-hacking task m s i monitor)
+  ;; Log all new data up to the match.
+  (let* ((delta (- (string-length s) (string-length i)))
+	 (mend (- (match:end m 0) delta)))
+    (monitor task (substring i 0 mend))
+    (monitor task m))
+  (set-prematch task s m))	; Set the prematch buffer.
+
+
+;;; The default monitor -- does nothing.
+(define (null-monitor task event) #f)
+
+(define (port->monitor p)
+  (let ((strs '())
+	(cr (string-ref "\r" 0))) ; Ugh.
+    (lambda (task event)
+      (format (error-output-port) "strs=~s\n" strs)
+      (let ((flush-trailing-line
+	     (lambda () 
+	       (write-string "Expect: " p)
+	       (for-each (lambda (s) (write-string s p))
+			 (reverse strs))
+	       (set! strs '())))
+
+	    (add-line-frag
+	      (lambda (s) (if (> (string-length s) 0)
+			      (set! strs (cons s strs)))))
+
+	    ;; Index of the last cr or nl, or false. Lame code.
+	    (last-line-break
+	      (lambda (s)
+		(cond ((string-index-right s #\newline) =>
+		       (lambda (last-nl)
+			 (max last-nl (or (string-index-right s cr) -1))))
+		      (else (string-index-right s cr))))))
+
+	(cond ;; EOF event
+	      ((not event)
+	       (cond ((pair? strs)
+		      (flush-trailing-line)
+		      (write-char #\newline p)))
+	       (write-string "Expect: End of file\n" p))
+
+	      ;; New-input event
+	      ;; We write out stuff in line chunks.
+	      ((string? event)
+	       (cond ((last-line-break event) =>
+		      (lambda (lb)
+			(flush-trailing-line)
+			(write-string event p 0 (+ 1 lb))
+			(add-line-frag (substring event
+						  (+ lb 1)
+						  (string-length event)))))
+		     (else (add-line-frag event))))
+
+	    ;; Match event
+	    ((regexp-match? event)
+	     (flush-trailing-line)
+	     (write-string "-- got it.\n" p))
+
+	    ;; Timeout event
+	    ((eq? event 'timeout)
+	     (cond ((pair? strs)
+		    (flush-trailing-line)
+		    (write-char #\newline p)))
+	     (write-string "Expect: Timed out.\n" p))	     
+	    
+	    (else (format p "Expect: Unknown event ~a\n" event))))
+      (force-output p))))
+
+
+;;; When we first start the expect form, there may be saved-up data in
+;;; the task's push-back buffer. If so, we need to try and match it with
+;;; the task's try-match function TM. If not, we jump off to OTHERWISE.
+
+(define (first-try task tm otherwise)
+  (let ((s (task:buf task)))
+    (if (zero? (string-length s)) (otherwise)
+	(tm s s otherwise))))
diff --git a/scheme/let-match.scm b/scheme/let-match.scm
new file mode 100644
index 0000000..6447cb0
--- /dev/null
+++ b/scheme/let-match.scm
@@ -0,0 +1,99 @@
+;;; These are some macros to support using regexp matching.
+
+;;; (let-match m mvars body ...)
+;;; Bind the match & submatch vars, and eval the body forms.
+
+(define-syntax let-match
+  (lambda (exp r c)
+    (if (< (length exp) 3)
+	(error "No match-vars list in LET-MATCH" exp))
+    (let ((m (cadr exp))		; The match expression
+	  (mvars (caddr exp))		; The match vars
+	  (body (cdddr exp))		; The expression's body forms
+
+	  (%begin           (r 'begin))
+	  (%match:substring (r 'match:substring))
+	  (%let*            (r 'let*)))
+
+      (cond ((null? mvars) `(,%begin ,@body))
+
+	    ((pair? mvars)
+	     (let* ((msv (or (car mvars) (r 'match-val))) ; "match-struct var"
+		    (sm-bindings (let recur ((i 0) (vars (cdr mvars)))
+				   (if (pair? vars)
+				       (let ((var (car vars))
+					     (bindings (recur (+ i 1) (cdr vars))))
+					 (if var
+					     (cons `(,var (,%match:substring ,msv ,i))
+						   bindings)
+					     bindings))
+				       '()))))
+	       `(,%let* ((,msv ,m) ,@sm-bindings) ,@body)))
+
+
+	    (else (error "Illegal match-vars list in LET-MATCH" mvars exp))))))
+
+(define-syntax if-match
+  (syntax-rules ()
+    ((if-match match-exp mvars on-match no-match)
+     (cond (match-exp => (lambda (m) (let-match m mvars on-match)))
+	   (else no-match)))))
+
+;;; (MATCH-COND (<match-exp> <match-vars> <body> ...)
+;;;             (TEST <exp> <body> ...)
+;;;             (TEST <exp> => <proc>)
+;;;             (ELSE <body> ...))
+;;;
+;;; The first clause is as-in IF-MATCH; the next three clauses are as-in COND.
+;;;
+;;; It would be slicker if we could *add* extra clauses to the syntax
+;;; of COND, but Scheme macros aren't extensible this way.
+ 
+(define-syntax match-cond
+  (syntax-rules (else test =>)
+    ((match-cond (else body ...) clause2 ...) (begin body ...))
+
+    ((match-cond) (cond))
+
+    ((match-cond (TEST exp => proc) clause2 ...)
+     (let ((v exp)) (if v (proc v) (match-cond clause2 ...))))
+
+    ((match-cond (TEST exp body ...) clause2 ...)
+     (if exp (begin body ...) (match-cond clause2 ...)))
+
+    ((match-cond (TEST exp) clause2 ...)
+     (or exp (match-cond clause2 ...)))
+
+    ((match-cond (match-exp mvars body ...) clause2 ...)
+     (if-match match-exp mvars (begin body ...)
+	       (match-cond clause2 ...)))))
+
+(define-syntax match-cond
+  (syntax-rules ()
+    ((match-cond clause ...) (match-cond-aux () clause ...))))
+
+(define-syntax match-cond-aux
+  (syntax-rules (test else)
+
+   ;; No more clauses.
+   ((match-cond-aux (cond-clause ...))
+    (cond cond-clause ...))
+
+   ;; (TEST . <cond-clause>)
+   ((match-cond-aux (cond-clause ...)
+		    (test . another-cond-clause) clause2 ...)
+    (match-cond-aux (cond-clause ... another-cond-clause)
+		    clause2 ...))
+   
+   ;; (ELSE <body> ...)
+   ((match-cond-aux (cond-clause ...)
+		    (else body ...) clause2 ...)
+    (match-cond-aux (cond-clause ... (else body ...))))
+
+   ;; (<match-exp> <mvars> <body> ...)
+   ((match-cond-aux (cond-clause ...)
+		    (match-exp mvars body ...) clause2 ...)
+    (match-cond-aux (cond-clause ... (match-exp => (lambda (m)
+						     (let-match m mvars
+						       body ...))))
+		    clause2 ...))))
diff --git a/scheme/packages.scm b/scheme/packages.scm
new file mode 100644
index 0000000..3ad812f
--- /dev/null
+++ b/scheme/packages.scm
@@ -0,0 +1,74 @@
+(define-structure tty-utils
+  (export modify-tty echo-off echo-on raw raw-initialize)
+  (open scsh let-opt scheme)
+  (files tty-utils))
+
+(define-structure let-match-package
+  (export (let-match :syntax)
+	  (if-match  :syntax)
+	  (match-cond :syntax))
+  (for-syntax (open scheme
+		    signals))	; For ERROR
+
+  (open scsh scheme)
+  (access signals) ; for ERROR
+
+  (files let-match))
+
+(define-structure expect-syntax-support
+  (export expand-expect)
+  (open scheme structure-refs
+	receiving) ; for making alien containers.
+  (access signals) ; for ERROR
+  (files expect-syntax))
+
+(define-structure expect-package
+  (export task? make-task copy-task
+	  task:process set-task:process modify-task:process
+	  task:in set-task:in modify-task:in
+	  task:out set-task:out modify-task:out
+	  task:buf set-task:buf modify-task:buf
+	  task:pre-match set-task:pre-match modify-task:pre-match
+
+	  port->monitor
+
+	  user-task file->task ports->task close-task
+	  spawn* (spawn :syntax)
+	  tsend tsend-line
+	  (expect :syntax))
+  (for-syntax (open expect-syntax-support scheme))
+
+  (open scsh formats structure-refs let-match-package
+	receiving defrec-package scheme srfi-13)
+  (access signals) ; for ERROR
+
+  (files expect))
+
+(define-structure chat-package
+  (export chat-abort chat-timeout chat-monitor
+	  port->chat-logger file->chat-logger
+	  (look-for 	      :syntax)
+	  (chat 	      :syntax)
+	  send send/cr)
+
+  (open scsh expect-package fluids scheme)
+
+  (files chat))
+
+(define-structure printf-package
+  (export printf sprintf display/cr display/nl)
+  (open scsh formats scheme)
+
+  (begin
+
+    (define (printf  fmt . args) (apply format (current-output-port) fmt args))
+    (define (sprintf fmt . args) (apply format #f fmt args))
+
+    (define (display/cr str . maybe-port)
+      (apply display str maybe-port)
+      (apply write-string "\r" maybe-port))
+    
+    (define (display/nl str . maybe-port)
+      (apply display str maybe-port)
+      (apply write-string "\n" maybe-port))
+    ))
