diff --git a/build/build.tcl b/build/build.tcl
index 9b62df63..668f61f6 100644
--- a/build/build.tcl
+++ b/build/build.tcl
@@ -2027,6 +2027,25 @@ respond "_" "\032"
 type ":kill\r"
 respond "*" ":lisp scheme (dump)\r"
 
+# More LIBLSP packages
+respond "*" "complr\013"
+respond "_" "liblsp;_libdoc;didl\r"
+respond "_" "liblsp;_libdoc;getsyn\r"
+respond "_" "liblsp;_libdoc;iter\r"
+respond "_" "liblsp;_libdoc;hash\r"
+respond "_" "liblsp;_libdoc;graph3\r"
+respond "_" "liblsp;_libdoc;ledit*\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" "complr\013"
+respond "_" "liblsp;_libdoc;stacks\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":midas liblsp;_libdoc;dirsiz\r"
+respond "*" ":midas liblsp;_z;timer\r"
+
 bootable_tapes
 
 # make output.tape
diff --git a/doc/libdoc/didl.chart b/doc/libdoc/didl.chart
new file mode 100755
index 00000000..f94cd66f
--- /dev/null
+++ b/doc/libdoc/didl.chart
@@ -0,0 +1,104 @@
+                                 DIDL Commands
+
+(didl) enters the debugger.  It is entered automatically when stepping or
+       when a breakpoint is hit.
+(dstep form) starts stepping form.
+
+n       indicates an optional numeric argument, typed before the command.
+	1 is assumed if no argument is given.
+-       - indicates the command will take a negative argument.
+	- without a number following it is taken to be -1.
+form    indicates the command prompts for a form to be typed in.
+func    indicates the command prompts for a function name.
+bpt     indicates the command prompts for a breakpoint name.
+
+Window Manipulation
+
+  <        First window.
+  >        Last window.
+n V        n'th next window.
+-nV	   n'th previous window.
+  L        Redisplay.
+  (        Show left parenthesis of current form.
+  )        Show right parenthesis.
+
+
+Frame Display
+
+  F        Show the stack frames.
+n P        Go up a stack frame.
+n N        Go down a stack frame.
+n J        Jump to stack frame n.
+  .        Select the current stack frame and display the user code
+           it corresponds to, if possible.
+
+
+Looking at function definitions
+
+  X func   Examine a user function.
+n I        Move forward to the left parenthesis of the next form, no
+           matter what depth it is at, making that form the current form. (In)
+n O        Move backward to the previous form.  (Out)
+n N        Move forward to the next form at this depth.  (Next)
+n P        Move backward to the previous form at this depth.  (Previous)
+  G func   Regrind a user function, even if it has been ground before.
+
+
+Doing things in the current frame
+
+  E form   Evaluate a form using the environment of the current frame.
+  R form   Force the return of a given value from the current frame.
+
+
+Stepping and breakpoints
+
+  C        Continue from stepping or a breakpoint.
+  ,        Continue from stepping or a breakpoint, but show the value
+           that will be returned before continuing.
+  ;        Step deeper, and show the value that will be returned.
+  BS       Set a breakpoint at the current form.
+  BC       Clear the breakpoint at the current form.
+  BI form  Set an if-condition on the current breakpoint, or reenable the
+	   previously set if-condition.  The breakpoint will break only
+           if the condition is non-nil.
+- BI	   Disable the if-condition.
+  BA form  Set an action on the current breakpoint,
+	   or reenable the previously set action.  The action will always
+           be done, even if the breakpoint does not break because of a
+           condition.
+- BA	   Disable the action.
+  BP form  Set a patch on the current breakpoint,
+	   or reenable the previously set patch.  The value of the patch
+           will be returned instead of the value given by the form at the
+           breakpoint.  The form at the breakpoint will not be eval'd.
+- BP	   Disable the patch.
+  BT       Tell about the current breakpoint, listing its name, condition,
+           action, and patch.
+  BL       List the names of all breakpoints.
+  BG bpt   Go to the given breakpoint, displaying where it is.
+
+
+When-conditions
+
+  WG	   Set a global when-condition, or reenable the previously set one.
+	   If the given condition becomes non-NIL, a break will occur.
+	   The condition is checked at all times.
+- WG	   Disable the global when-condition.
+  WL	   Set a local when-condition, or reeanble the previously set one.
+	   The condition is checked only at the point at which it was set
+	   and deeper into the stack.
+- WL	   Disable the local when-condition.
+  WT	   Tell about the global and local when-conditions.
+
+Miscellaneous
+
+  Q        Quit from DIDL.
+  ?        Print a list of all commands, with short descriptions.
+  ^L       Clear the Echo-Area.
+  ^A       Turn off the split screen used by DIDL.  Useful if you accidently
+           or deliberately get out of DIDL without it turning off the split
+           screening.  Do not use while DIDL is running.
+  ^E	   Enter DIDL. Same as typing "(didl)".
+  <space>
+  <cr>
+  <lf>     are ignored.
diff --git a/doc/libdoc/didl.help b/doc/libdoc/didl.help
new file mode 100755
index 00000000..945919f8
--- /dev/null
+++ b/doc/libdoc/didl.help
@@ -0,0 +1,46 @@
+<  First window.
+>  Last window.
+V  Next or previous window.
+L  Redisplay.
+(  Show left paren.
+)  Show right paren.
+
+I  Move to next textual left paren. (In)
+O  Move to previous textual left paren. (Out)
+N  Move forward to the next form at this depth.  (Next)
+P  Move backward to the previous form at this depth.  (Previous)
+
+F  Show the stack frames.
+P  Go up a stack frame.
+N  Go down a stack frame.
+J  Jump to stack frame.
+.  Select the current stack frame for display.
+
+X  Examine a user function.
+G  Regrind a user function.
+
+E  Evaluate a form using the environment of the current frame.
+R  Force the return of a given value from the current frame.
+
+C  Continue from stepping or a breakpoint.
+,  Continue from stepping or a breakpoint; show value returned.
+;  Step deeper; show the value that will be returned.
+
+BS  Set a breakpoint.
+BC  Clear the breakpoint at the current form.
+BI  Set an if-condition on the current breakpoint.
+BA  Set an action on the current breakpoint.
+BP  Set a patch on the current breakpoint.
+BT  Tell about the current breakpoint.
+BL  List the names of all breakpoints.
+BG  Go to the given breakpoint, displaying where it is.
+
+WG  Set a global when-condition.
+WL  Set a local when-condition.
+WT  Tell about the when-conditions.
+
+Q   Quit from DIDL.
+?   Print this text.
+^L   Clear the Echo-Area.
+^A   Turn off the split screen used by DIDL.
+^E   Enter DIDL. Same as typing "(didl)".
diff --git a/doc/libdoc/didl.info b/doc/libdoc/didl.info
new file mode 100755
index 00000000..f3642384
--- /dev/null
+++ b/doc/libdoc/didl.info
@@ -0,0 +1,234 @@
+DIDL is a MACLISP debugger for use on display terminals.  The display features
+of DIDL show user program code in context: for instance, when the user program
+hits a breakpoint, DIDL automatically shows not only the point at which the
+breakpoint occurred, but also the surrounding code.  Single-stepping moves a
+cursor through the user code, showing exactly what is to be executed, in
+context.
+
+Because of its size, and the general lack of disk space, the source of DIDL
+is only on ML:LIBDOC;DIDL >.
+
+DIDL works on uncompiled code only.  Make your macros non-displacing, or DIDL
+will get very confused.
+
+
+Loading and invoking
+
+Load DIDL from LIBLSP;DIDL FASL.  To invoke DIDL, type (didl), or just
+C-E, if you haven't already assigned some other function to C-E.  To
+single-step some form, type (dstep <form>) [more on stepping below].
+
+
+Commands
+
+All DIDL commands are one or two letters long, with an optional positive or
+negative numeric argument.  If no argument is given, 1 is assumed.  If just a
+'-' is given, -1 is assumed.
+
+Sometimes some commands will prompt for another argument.  To abort a command
+after such a prompt, just rubout past the left end.  Some commands also assume
+some default after prompting.  To get the default, just type space.
+
+
+Displaying code
+
+DIDL will display your EXPR's or LEXPR's by grinding them and then displaying
+the ground function.  (If you make extensive use of reader macros, you may
+not recognize your code.)
+
+To display a function, type
+
+	X
+
+(for eXamine).  You will be prompted for a function name.  After the function
+has been ground and displayed, you can use EMACS-like commands to move around
+in the function.  At any time, the DIDL cursor is pointing to some
+parenthesized LISP form, and will show you the left or right parenthesis for
+that form.  The following commands are available (an n before a command
+indicates it takes an optional numeric argument:
+
+	<	Move to the beginning of the function.  (Like M-< in EMACS.)
+	>	Move to the end of the function.
+	nV	Move forward n pages.
+	-nV	Move backward n pages.
+	L	Redisplay the screen, in case it has been garbled.
+	(	Show the left parenthesis of the current form (normal case).
+	)	Show the right parenthesis.
+	nI	Move forward n left parentheses.  This is a textual move
+			and ignores the actual nesting of parentheses.
+	nO	Move backward n left parentheses.
+	nN	Move forward n parentheses at this nesting level.  If n
+			n is too large, just move to the last
+			left parenthesis at this level.
+	nP	Move backward n left parentheses at this nesting level.
+
+Note that unlike EMACS, DIDL will not change its idea of where the current
+form is, even if, say a V command moves it out of sight.  Thus the ( command
+will always return you to the current form, and may force a different page to
+be displayed.
+
+
+Single-stepping
+
+To single step a lisp form, type
+
+	(dstep <form>)
+
+DIDL will start stepping the form, and show you what is about to be executed
+every time you single step.  When some atom or (QUOTE <something>) is about to
+be evaluated, DIDL will display the form and will type
+
+	--Continue--
+
+Just hit space or any other character to continue.  When some more complicated
+form is about to be evaluated, DIDL will display the form, in context if
+possible, and wait for you to type any DIDL command.  The commands that
+continue stepping are:
+
+	C	Continue, without stepping deeper.
+	,	Continue without stepping deeper, but show the value of the
+			form that was evaluated, and wait for the user to type
+			space to continue.
+	;	Continue, breaking on deeper evaluations, and show the value
+			form that was evaluated.
+
+
+Displaying the stack
+
+During the evaluation of any form, a backtrace of the stack can be displayed.
+A typical line of the frame display looks like:
+1: Broke at AFUNCTION: (COND ((= X 5) (SETQ Y (GROMMET 'APPLE 6 2)) (RETURN
+
+The number on the left side is the frame level number.  The top frame is
+numbered 1.  The "Broke at" message indicates that the frame to evaluate this
+form has not actually been created yet; this happens when DIDL stops on a form
+because of single-stepping or because it has hit a breakpoint.  This message
+is not printed if the frame actually exists.  Then the name of the function
+(if there is one) and as much code as will fit on one line is printed.
+
+If the frame display occupies more than one page, you can use the <, >, V,
+and L commands to look at other pages.
+
+One stack frame is always selected, and is indicated by the cursor at the
+left-hand edge.  To select another stack frame, use the following commands:
+
+	nP	Go up n stack frames.
+	nN	Go down n stack frames
+	nJ	Jump directly to stack frame n.
+
+Once you have selected a stack frame, you can display the code for that frame,
+in context:
+
+	.	Display the user code for this stack frame, if possible.
+
+
+Evaluation in the current frame
+
+	E	Evaluate.  E prompts for a form, and then evaluates the form
+			in the environment of the current frame.  You can use
+			this command to examine variable bindings.
+	R	Return.  R prompts for a form, evaluates the form in the
+			environment of the current frame, and then forces a
+			return from this frame with the given value.
+
+
+Breakpoints
+
+You can set breakpoints in any uncompiled function at any time.  These
+breakpoints are non-destructive, and do not actually alter the code.
+
+	BS	Set a breakpoint at the current form.  You can give the
+			breakpoint a name, or use a supplied default name.
+	BC	Clear the breakpoint at the current form.
+	BG	Go to the breakpoint you name, displaying where it is.
+
+To clear a breakpoint, you will have to BG to it, and then BC it if you want
+to clear it, unless you are already sitting on it.
+
+Associated with each breakpiont can be an if-condition, an action, and a
+patch.  For new breakpoints, all three of these are disabled, and the
+breakpoint does nothing except unconditionally break when it is reached.
+
+An if-condition is a form that is evaluated to determine if the breakpoint
+should should cause a break.  A break will occur only if the if-condition
+evaluates to non-NIL.
+
+An action is a form that is always evaluated whenever a breakpoint is hit,
+even if the if-condition evaluates to NIL.  Naturally, an action is evaluated
+solely for its side effects.
+
+A patch is also a form that is always evaluated whenever a breakpoint is hit.
+The value of the patch is returned as the value of the form that would have
+been evaluated at the breakpoint.  The code at the breakpoint is never
+evaluated.
+
+	BI	Set a new if-condition on the current breakpoint, or
+			reenable the old if-condition.
+	-BI	Disable the if-condition.
+	BA	Set or reeneable an action.
+	-BA	Disable the action.
+	BP	Set or reenable a patch.
+	-BP	Disable the patch.
+
+Finally, there are two informational breakpoint commands:
+
+	BL	List all the breakpoints that are currently set.
+	BT	Tell about the current breakpoint, listing its if-condtion,
+			action, and patch.
+
+
+When-conditions
+
+When conditions cause a break whenever a certain condition is satisfied.
+They can be used, for instance, to determine when a variable becomes bound to
+a particular value.
+
+There are global and local when-conditions.  A local when-condition is
+checked for only from the current point into the stack and deeper.  When the
+current frame vanishes, the local when-condition disappears.  The scope of a
+local when-condition is the same as that of a Lisp variable.  The global
+when-condition is like a SPECIAL variable.  There is only one global
+when-condition, and it is checked for at all times.
+
+When-conditions are evaluated on every call to EVAL, so they will slow your
+program down.
+
+	WG	Set or reenable the global when-condition.
+	-WG	Disable the global when-condition.
+	WL	Set or reenable the local when-condition.
+	-WL	Disable the local when-condition.
+	WT	Tell about the when-conditions.
+
+ONce a when-condition break has occurred, it is usually a good idea to disable
+the when-condition immediately, because it will be true during every
+subsequent call to EVAL, until the state it depends on is changed.
+
+
+Miscellaneous
+
+	Q	Quit from DIDL.  Be careful, as you may return to a previous
+			invocation of DIDL.  Use C-G if you want to forget the
+			whole mess.
+	?	Print a list of all commands and descriptions.
+	G	Regrind some function.  Useful if something has been reloaded
+			or messed up.
+	C-L	(control-L) Clear the echo area.
+	C-A	Turn of the split screen used by DIDL.  Useful if you
+			accidently get out of DIDL, and the screen is still
+			split.
+	C-E	Enter DIDL.  Same as typing (didl).
+	<space>
+	<cr>
+	<lf>	are ignored.
+
+
+Known problems
+
+Having to go to a breakpoint to work on it is a nuisance.
+The moving-around commands could be improved.
+B? and W? should print lists of commands.
+Don't try to use DIDL in conjunction with other debugging programs that use
+EVALHOOK (e.g. steppers), or lots of things will go wrong.
+
+Dan Halbert (DCH@ML, BUG-DIDL@ML)
+This version July 1980.
\ No newline at end of file
diff --git a/src/libdoc/didl.dch259 b/src/libdoc/didl.dch259
new file mode 100644
index 00000000..56a7c4e8
--- /dev/null
+++ b/src/libdoc/didl.dch259
@@ -0,0 +1,2527 @@
+;;;-*-Lisp-*-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;;  DIDL: A LISP debugger for display terminals
+;;;
+;;;  Copyright 1978 by Daniel C. Halbert   (DCH@ML)
+;;;
+;;;  This project was undertaken as an S.B thesis.
+;;;  The thesis is entitled "A LISP Debugger for Display Terminals"
+;;;  and can be found in the Barker Engineering Library
+;;;  Microreproduction Center.
+;;;   Thesis Advisor:  Peter Szolovits
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(eval-when (eval)
+	   (cond ((or (not (= ibase 8.))
+		      (not (= base 8.)))
+		  (format T '|~&Setting the base to eight.~&|)
+		  (setq base 8)
+		  (setq ibase 8))))
+
+;;; I just want vanilla, cheap-to-run macros, hence the below.
+
+(setq macro-expansion-use 'displace)
+(eval-when (compile)
+	   (setq defmacro-check-args nil))
+
+;;; Macros and useful functions taken from DCH;LISP! >.
+
+
+;;; (allbutlast '(1 2 3 4)) => (1 2 3)
+
+(eval-when (compile load)
+	   (defun allbutlast (list)
+		  (if (null (cdr list))
+		      nil
+		      (cons (car list) (allbutlast (cdr list))))))
+
+;;; (nillist 4) => (nil nil nil nil)
+
+(eval-when (compile load)
+	   (defun nillist (num)
+		  (if (zerop num)
+		      nil
+		      (cons nil (nillist (1- num))))))
+
+(defmacro 1st (l)
+	  `(car ,l))
+(defmacro 2nd (l)
+	  `(cadr ,l))
+(defmacro 3rd (l)
+	  `(caddr ,l))
+(defmacro 4th (l)
+	  `(cadddr ,l))
+
+
+(defmacro do-forever (&rest forms)
+	  `(do () (nil) ,@forms))
+
+
+
+(defmacro for (var start end &rest forms)
+	`(do ,var ,start (1+ ,var)
+	     (> ,var ,end) ,@forms))
+
+
+
+(defmacro vars (names &rest forms)
+	  `((lambda ,names ,@forms)
+	    ,@(nillist (length names))))
+
+
+(defmacro <= (a b)
+	  `(not (> ,a ,b)))
+
+(defmacro >= (a b)
+	  `(not (< ,a ,b)))
+
+
+
+;;; (defstructure <structure> <item-1> <item-2> ...)
+;;;
+;;; (defstructure pkt address data) defines many macros:
+;;; (create-pkt)                 => (hunk nil nil 'pkt)
+;;;   [Thus (cdr <structure>) gives the structure's type.]
+;;; (pkt^address a-pkt)          => (cxr 1 a-pkt)
+;;; (store-pkt^address a-pkt 45) => (rplacx 0 a-pkt 45)
+;;; (pkt^data a-pkt)             => (cxr 2 a-pkt)
+;;; (store-pkt^data a-pkt 32)    => (rplacx 1 a-pkt 32)
+
+
+(defmacro defstructure (structure-name &rest structure-fields)
+	  `(progn
+	    'compile
+	    (defmacro ,(implode (append '(c r e a t e -)
+					(explode structure-name)))
+		       ()
+		       `(hunk . ,(append (nillist ,(length structure-fields))
+					 '(',structure-name))))
+	    . ,(do ((item-list structure-fields (cdr item-list))
+		    (item-name-chars)
+		    (structure-name-chars (explode structure-name))
+		    (item-number 1 (1+ item-number))
+		    (item-defs))
+		   ((null item-list) item-defs)
+
+		   (setq item-name-chars (explode (car item-list)))
+		   (push `(defmacro
+			   ,(implode (append structure-name-chars
+					     '(^)
+					     item-name-chars))
+			   (structure)
+			   `(cxr ,,item-number ,structure))
+			 item-defs)
+		   (push `(defmacro
+			   ,(implode (append '(s t o r e -)
+					     structure-name-chars
+					     '(^)
+					     item-name-chars))
+			   (structure value)
+			   `(rplacx ,,item-number ,structure ,value))
+			 item-defs))))
+
+
+;;; array macros and functions
+
+(defmacro arraystore (array &rest args)
+	  `(store (arraycall t ,array ,@(allbutlast args)) ,@(last args)))
+
+(defmacro arrayget (array &rest args)
+	  `(arraycall t ,array ,@args))
+
+(defmacro newarray (&rest args)
+	  `(*array nil t ,@args))
+
+(declare (*lexpr didl
+		 stuff-line
+		 window-set-status-line
+		 echo-area-prompt-and-read
+		 echo-area-prompt-and-read-with-default
+		 unsplit-screen))
+
+;;; "See DS" means see the data structure description page below.
+
+(declare (special didl		; NIL if DIDL not yet initialized.
+		  tyi		; Standard input and output.
+		  tyo
+		  errlist	; progn eval'd on ^G.
+		  $window-tty	; TTY channels for DIDL.  See Open-TTYS.
+		  $echo-area-tty
+		  $is-screen-split?	; Is echo area set up?
+		  $screen-width		; Effective width of display screen.
+		  $hash-table		; SX hash table.  See data structure
+					;  description below.
+		  $echo-area-length	; Number of lines in the echo area.
+		  $window-length	; Number of lines in the window.
+		  $info-area-length	; Number of lines in the info area,
+					;  between the window and echo area.
+		  $status-line		; Current status ("info") line.
+		  $ht-size		; Size of $hash-table.
+
+		  $breakpoint-list	; List of current breakpoints.
+					;  For use by DIDL-Evalhook (q.v.)
+		  $global-when-condition; Global predicate set by user
+					;  to break on.
+		  $global-when-condition-enable
+					; The when-condition is checked for.
+		  $local-when-condition	; Local predicate, lambda-bound
+					;  by each invocation of DIDL.
+		  $local-when-condition-enable
+		  $unique-number	; To get a unique breakpoint name.
+		  $unique-symbol	; Used where such a thing is needed.
+
+		  $last-screen		; A Screen.  See DS.
+					;  The last one displayed.
+		  $last-screen-type	; See Screen in DS.
+		  $last-pos		; Where cursor was last.  See DS.
+		  $last-top-window-line	; Line of Screen that is at top of
+            				;  Window.
+
+		  ;; These symbols are bound to the characters that
+		  ;;  correspond to the commands.
+
+		  $command-first-window  $command-last-window
+		  $command-next-or-previous-window  $command-rewindow
+		  $command-show-left-paren  $command-show-right-paren
+		  $command-look-at-frames
+		  $command-jump-to-frame
+		  $command-show-frame
+		  $command-into-sx  $command-out-of-sx
+		  $command-next  $command-previous
+		  $command-examine-user-function
+		  $command-grind-function
+		  $command-evaluate-in-frame
+		  $command-force-return-from-frame
+		  $command-continue $command-show-value $command-step-deeper
+		  $command-help
+		  $command-quit
+
+		  ;; All the breakpoint commands.
+
+		  $command-breakpoint
+		  $bkpt-command-set-breakpoint  $bkpt-command-clear-breakpoint
+		  $bkpt-command-tell-about-breakpoint
+		  $bkpt-command-list-all-breakpoints
+		  $bkpt-command-goto-breakpoint
+		  $bkpt-command-set-if
+		  $bkpt-command-set-action
+		  $bkpt-command-set-patch
+
+		  ;; The When-Condition commands.
+
+		  $command-when
+		  $when-command-local
+		  $when-command-global
+		  $when-command-tell-about-when-conditions
+
+		  ;; Chars to ignore when trying to read commands (space, etc.)
+
+		  $command-chars-to-ignore))
+
+;;; Structures for DIDL
+
+
+;;; Pos:
+;;;      A pos is a two-element list: (<line> <col>).  Its components are
+;;; screen co-ordinates.
+
+;;; Screen:
+;;;         A screen is an array of lines.  (arrayget screen 0) is the
+;;; last used line in the screen.  Screens are grown if necessary.  They
+;;; may have unused components at the end which are NIL.
+;;; Screens are used to hold text which the user needs to peruse, and which
+;;; may not fit in one display window.  Ground function-forms and stack
+;;; traces are stored in screens.
+;;; Screens have types: No-Screen = no Screen is being displayed.
+;;;			User-Function-Screen = Ground user function.
+;;;			Frame-Screen = Stackframe trace.
+
+
+;;; Window:
+;;;        The tox ($window-length + 1 + $info-area-length) lines on the user's
+;;; display terminal are the window.  The window is used mostly for displaying
+;;; parts of screens, and for displaying static information.
+;;; The status line is just below the main window.
+;;; The two lines below it are the info-area which is
+;;; used for displaying "Stepping", etc. messages.
+
+;;; Line:
+;;;       A line is an array that is $screen-width+1 long.
+;;; Characters are stored as fixnums.  Some elements are markers (see below).
+;;; (arrayget line 0) indicates the last used char on the line.
+;;; Lines do not have CRLF at the end.  When a line is created it is filled
+;;; with spaces (40's).
+
+;;; Loc:
+;;; loc's contain information about where things are on a screen,
+;;; and are usually stored in markers (see below).
+;;; atomloc's are not stored on screen, but are just returned by put-atom.
+
+(defstructure atomloc
+	      begin-pos	      ; Where is first char of atom?
+	      end-pos	      ; Where is last char?
+	      the-atom)	      ; The atom itself.
+
+
+(defstructure leftparenloc    ; Information about where an sx is, stored at
+			      ;  the left paren.
+	      begin-pos	      ; Where is the left paren?
+	      end-pos	      ; Where is right paren?
+	      sx)	      ; The sx itself which this loc is for.
+
+
+(defstructure rightparenloc   ; Information about where an sx is, stored at
+			      ;  the right paren.
+	      begin-pos	      ; Where is the left paren?
+	      end-pos	      ; Where is right paren?
+	      sx)	      ; The sx itself which this loc is for.
+
+
+;;; marker:
+;;;         A marker is a cons that sometimes substitutes for
+;;; just a char (a fixnum) in a line.  A marker is:
+;;; (<char> . <loc>), where <loc> is a leftparenloc or rightparenloc.
+;;; Markers are used for finding out where sx's begin and end on screens.
+
+(defstructure breakpoint      ; Info about a breakpoint.
+	      name	      ; An atom, can be set by user.
+	      function	      ; The function in which this breakpoint is set.
+	      if	      ; Break to user only if this eval's to not NIL.
+	      if-enable	      ; T to indicate that action should be used.
+	      action	      ; Eval this whenever the breakpoint is hit,
+			      ;  even if it doesn't break to the user.
+	      action-enable   ; T to indicate that action should be used.
+	      patch	      ; force return of (eval patch).
+	      patch-enable)   ; T to indicate that patch should be used.
+
+;;; Breakpoints are stored on $breakpoint list in the format:
+;;; ( (sx . breakpoint) ...)  where sx is the form to be broken on.
+
+;;; Set up.
+
+(setq didl nil			; DIDL is not yet initialized.
+      $breakpoint-list nil	; No breakpoints yet.
+      $global-when-condition nil	; No when-conditions yet.
+      $global-when-condition-enable nil
+      $local-when-condition nil
+      $local-when-condition-enable nil
+      $ht-size 997.		; Should be a prime number.
+      $unique-number 0
+      $unique-symbol (gensym)
+      $is-screen-split? nil
+      $info-area-length 2
+      $echo-area-length 9.)
+
+;;; Set up all the command characters.
+
+(setq $command-first-window 74		     ; <    
+      $command-last-window  76		     ; >
+      $command-next-or-previous-window  126  ; V
+      $command-rewindow	 114		     ; L
+      $command-show-left-paren 50	     ; (
+      $command-show-right-paren 51	     ; )
+      $command-look-at-frames 106	     ; F
+      $command-jump-to-frame  112	     ; J
+      $command-show-frame  56		     ; .
+      $command-into-sx  111		     ; I
+      $command-out-of-sx  117		     ; O
+      $command-next  116		     ; N
+      $command-previous  120		     ; P
+      $command-examine-user-function  130    ; X
+      $command-grind-function  107           ; G
+      $command-evaluate-in-frame  105	     ; E
+      $command-force-return-from-frame  122  ; R
+      $command-continue  103		     ; C
+      $command-show-value  54		     ; ,
+      $command-step-deeper  73		     ; ;
+      $command-help  77			     ; ?
+      $command-quit  121		     ; Q
+
+      $command-breakpoint  102		      ; B
+      $bkpt-command-set-breakpoint  123	      ;  S
+      $bkpt-command-clear-breakpoint  103     ;  C
+      $bkpt-command-tell-about-breakpoint 124 ;  T
+      $bkpt-command-list-all-breakpoints 114  ;  L
+      $bkpt-command-goto-breakpoint  107      ;  G
+      $bkpt-command-set-if  111		      ;  I
+      $bkpt-command-set-action  101	      ;  A
+      $bkpt-command-set-patch  120	      ;  P
+
+      $command-when  127		      ; W
+      $when-command-local  114		      ;  L
+      $when-command-global  107		      ;  G
+      $when-command-tell-about-when-conditions  124
+					      ;  T
+
+      $command-chars-to-ignore '(15 12 13 14 40)	; cr lf ^K ^L space
+)
+
+
+;;; These functions are ground specially, so indicate so on their
+;;; property lists.
+
+(putprop 'lambda 'put-miser 'didl-put-format)
+(putprop 'cond 'put-miser 'didl-put-format)
+(putprop 'do 'put-miser 'didl-put-format)
+(putprop 'prog 'put-miser 'didl-put-format)
+(putprop 'progn 'put-miser 'didl-put-format)
+
+;;; Put the interrupt function that calls DIDL on Control-E.
+
+(or (status ttyint 5)
+    (sstatus ttyint 5 (function enter-didl)))
+
+;;; Function to enter DIDL.
+;;; (didl) is the way the user calls it.  didl-evalhook or
+;;; didl-evalhook-step call it as
+;;;  (didl 'stepping form) if we're stepping,
+;;;  (didl '$local-when-condition form) if the local when-condition
+;;;  evaluated to non-NIL, or
+;;;  (didl '$global-when-condition form) if the global when-condition
+;;;  evaluated to non-NIL, or
+;;;  (didl 'breakpoint form breakpoint) if a breakpoint was hit.
+
+(defun didl numbargs
+    (unwind-protect
+       (let
+	((evalhook nil)		; Don't enable DIDL-Evalhook now.
+	 (value)		; Value to quick-return.
+	 (quick-return)		; Don't read commands, just return.
+				;  For use in cases like (didl <atom>).
+	 ($local-when-condition $local-when-condition)
+				; Lambda-bind $local-when-condition to itself
+				;  so that previous $local-when-conditions will
+				;  be retained, but a new one may be set.
+	 ($local-when-condition-enable $local-when-condition-enable)
+	 (frame-array)		; Backtrace created by Framearray.
+				;  NIL if no frames.
+	 (frame-screen)		; Display of frame-array.
+	 (current-frame)	; Frame being looked at now, as returned by
+				;  EVALFRAME.
+	 (current-frame-number)	; Number of current frame.  Index into
+				;  current-frame. 1=top frame.
+	 (force-redisplay)	; Force the display to be redisplayed.
+	 (current-screen)	; Screen that is currently being displayed.
+	 (current-screen-type 'no-screen)	; No screen yet.
+	 (current-pos '(1 1))	; Upper left hand corner.
+	 (current-loc)		; Loc being used.
+	 (current-function)	; Name of function being displayed.
+	 (current-sx)		; Bound to SX currently being pointed to
+	 (broke-at-frame)	; If we broke, frame broken on.
+				;  NIL if we didn't break.
+	 (broke-at-loc)		; Similarly...
+	 (broke-at-function)
+	 (broke-at-sx)
+	 (broke-at-breakpoint)
+	 (breakpoint)		; The current breakpoint itself
+	 (current-screen-length)	; Length of current-screen.
+	 (command-arg)		; A number.
+	 (command-char)		; As typed by user.
+	 (how-many-frames)	; How many in frame-array.
+	 )
+
+	(or didl		; Is DIDL initialized yet?
+	    (progn		; No.
+ 	     (setq terpri t)	; Turn off auto-terpri.
+	     (open-ttys)	; Set up the new TTY channels.
+
+	     ;; Make Control-A undo the echo area.
+
+	     (or (status ttyint 1)
+		 (sstatus ttyint 1 (function unsplit-screen)))
+
+	     ;; Screen width must be one less so we avoid automatic wrapping.
+
+	     (setq $screen-width (1- (cdr (cond ((sfap tyo)
+						 (sfa-call tyo 'ttysize nil))
+						(t (status ttysize))))))
+
+	     (setq $window-length (- (car (cond ((sfap tyo)
+						 (sfa-call tyo 'ttysize nil))
+						(T (status ttysize))))
+				     $echo-area-length
+				     1			; 1 for status line.
+				     $info-area-length))
+
+	     (setq $breakpoint-list nil)
+
+	     (let ((didl-errlist	; Make Control-G enable DIDL-Evalhook.
+		   '(progn
+		     (setq evalhook (function didl-evalhook))
+		     (unsplit-screen))))	; Also restore full screen.
+		  (or (memq didl-errlist errlist)
+		      (push didl-errlist errlist)))
+
+	     (setq $status-line (create-line))
+	     (ht-setup $ht-size)	; Set up $hash-table.
+	     (setq didl t)))		; Now DIDL is initialized.
+
+;;; Always do the following upon entering DIDL.
+
+	(or $is-screen-split?		; Resplit screen if necessary.
+	    (progn
+	     (split-screen)
+	     (echo-area-clear)
+	     (setq $last-screen nil
+		   $last-screen-type 'no-screen
+		   $last-top-window-line nil
+		   $last-pos '(1 1))))
+
+	(setq force-redisplay t)	; The first time, must redisplay.
+
+	(setq current-frame (evalframe nil))	; Get top stack frame.
+	(setq frame-array (framearray current-frame))	; Get backtrace.
+
+	;; Grind all the user functions referred to in frame-array.
+
+	(and frame-array
+	     (progn
+	      (put-frame-array-user-functions frame-array)
+	      (setq current-frame
+		    (setq broke-at-frame (arrayget frame-array 1)))))
+
+	(setq current-frame-number 1)	; Start at top frame.
+	(window-set-status-line 'DIDL)
+
+;;; See if we were entered by the user, or by a breakpoint or stepping.
+
+	(and (> numbargs 0)	; Not entered by user.
+	     (progn
+	      (setq broke-at-sx (setq current-sx (arg 2)))
+
+	      ;; Try to display where we broke.
+	      (let ((ht-entry (ht-find broke-at-sx)))
+		   (setq broke-at-function            ; These could be NIL.
+			 (setq current-function (2nd ht-entry)))
+		   (setq broke-at-loc (setq current-loc (3rd ht-entry)))
+
+		   (cond
+		    ((null broke-at-loc)	; Didn't break in a user func.
+		     (setq current-screen nil)
+		     (setq current-screen-type 'no-screen)
+		     (setq force-redisplay t))
+		    (t				; Did break in a user function.
+		     (setq force-redisplay nil)
+		     (setq current-screen (get broke-at-function 'didl-screen))
+		     (setq current-screen-type 'user-function-screen)
+		     (setq current-pos (loc^begin-pos broke-at-loc)))))
+
+	      (cond
+	       ((eq (arg 1) 'breakpoint)	; Broke at a breakpoint.
+		(setq breakpoint (setq broke-at-breakpoint (arg 3)))
+		(info-area-clear)
+		(info-area-princ '|Hit breakpoint |)	; Say where.
+		(info-area-princ (breakpoint^name breakpoint))
+		(and (breakpoint^patch-enable breakpoint)
+		     (info-area-princ '|, but has an enabled patch!|)))
+						; Warn user about patches.
+	       ((or
+		 (eq (arg 1) 'stepping)
+		 (eq (arg 1) '$global-when-condition)
+		 (eq (arg 1) '$local-when-condition))
+		(cond
+
+		 ;; If stepping on atom or 'foo, just show what we're eval'ing
+		 ;;  and wait for user to indicate we can continue.
+
+		 ((or (atom broke-at-sx)
+		      (eq (car broke-at-sx) (function quote)))
+		  (info-area-clear)
+		  (info-area-prin1 broke-at-sx)
+		  (info-area-princ '| => |)
+		  (let ((prinlevel 3) (prinlength 4))
+		       (setq value (evalhook broke-at-sx nil))
+		       (info-area-prin1t value))
+		  (info-area-princ '|--Continue--|)
+		  (tyi)
+		  (setq quick-return t))
+		 (t
+		  (info-area-clear)
+		  (cond
+		   ((eq (arg 1) 'stepping)
+		    (info-area-princt '|Stepping   |))
+		   ((eq (arg 1) '$global-when-condition)
+		    (info-area-princ '|Global when-condition |)
+		    (info-area-print $global-when-condition)
+		    (info-area-princt '| satisfied	 |))
+		   ((eq (arg 1) '$local-when-condition)
+		    (info-area-princ '|Local when-condition |)
+		    (info-area-print $local-when-condition)
+		    (info-area-princt '|satisfied|)))))))))
+
+;;; Main command loop
+
+	(do-forever
+	 (and quick-return		; Used when eval'ing atom or 'foo.
+	      (return value))
+
+	 ;; Do redisplay of screen if necessary.
+
+	 (didl-redisplay current-screen current-screen-type current-pos
+			 current-sx current-function force-redisplay
+			 current-frame-number how-many-frames)
+
+	 (or $is-screen-split?
+	     (split-screen))	 ; In case someone has unsplit it e.g. a higher
+				 ;  invocation of DIDL.
+	 (setq force-redisplay nil)
+
+	 ;; Now that redisplay is done, update display info.
+
+	 (setq $last-screen current-screen)
+	 (setq $last-screen-type current-screen-type)
+	 (setq $last-pos current-pos)
+	 (and current-screen
+	      (setq current-screen-length (arrayget current-screen 0)))
+
+	 (and (eq current-screen-type 'frame-screen)
+	      (progn
+	       (setq current-frame-number (1st current-pos))
+	       (setq current-frame (arrayget frame-array current-frame-number))
+	       ))
+
+
+	 ;;Read an arg and command.
+
+	 (setq command-arg (read-command-arg))
+	 (setq command-char (read-command-char))
+
+	 ;;This catch catches on Abort-Command, so various commands
+	 ;; can be aborted.
+
+	 (and
+	  (eq
+	   'abort-command
+	   (catch
+	    (cond
+
+;;; Display manipulation commands.
+
+	     ;; Display first windowful of current-screen.
+
+	     ((= $command-first-window command-char)
+	      (if (eq current-screen-type 'no-screen)
+		  (didl-error '|No window to scroll.|)
+		  (setq current-pos '(1 1))))
+
+
+	     ;; Display last screenful.
+
+	     ((= $command-last-window command-char)
+	      (if (eq current-screen-type 'no-screen)
+		  (didl-error '|No window to scroll.|)
+		  (setq current-pos (list current-screen-length 1))))
+
+
+	     ;; Go forward or backward one or several windows, but
+	     ;; don't go too far.
+
+	     ((= $command-next-or-previous-window command-char)
+	      (if (eq current-screen-type 'no-screen)
+		  (didl-error '|No window to scroll.|)
+		  (setq current-pos
+			(list
+			 (force-into-range 1 current-screen-length
+					   (+ $last-top-window-line
+					      (if (> command-arg 0) -1 1)
+					      (// $window-length 2)
+					      (* $window-length command-arg)))
+			 1))))
+
+
+	     ;; Force the display to be redone.
+
+	     ((= $command-rewindow command-char)
+	      (setq force-redisplay t))
+
+
+	     ;; Point to the left paren of the current sx.
+
+	     ((= $command-show-left-paren command-char)
+	      (if (eq current-screen-type 'user-function-screen)
+		  (setq current-pos (loc^begin-pos current-loc))
+		  (didl-error '|Not looking at a user form.|)))
+
+
+	     ;; Point to the right paren of the current sx.
+
+	     ((= $command-show-right-paren command-char)
+	      (if (eq current-screen-type 'user-function-screen)
+		  (setq current-pos (loc^end-pos current-loc))
+		  (didl-error '|Not looking at a user form.|)))
+	     
+;;; Frame selection commands.
+
+
+	     ;; Display the frame backtrace.
+
+	     ((= $command-look-at-frames command-char)
+	      (cond
+	       (frame-array
+		(or frame-screen
+		    (setq frame-screen (make-frame-screen frame-array)))
+		(setq current-screen frame-screen)
+		(setq current-screen-type 'frame-screen)
+		(setq current-pos (list current-frame-number 1))
+		(setq how-many-frames (arrayget frame-array 0)))
+	       (t (didl-error '|No frames to display.|))))
+
+
+	     ;; Jump directly to the frame whose number is command-arg.
+
+	     ((= $command-jump-to-frame command-char)
+	      (if (eq current-screen-type 'frame-screen)
+		  (setq current-pos
+			(list (force-into-range 1 how-many-frames command-arg)
+			      1))
+		  (didl-error '|Not looking at frames.|)))
+
+
+	     ;; Show the user function and sx associated with the current
+	     ;; frame if possible, else just show the sx.
+	     ;; If we broke, frame #1 is  (DIDL-EVALHOOK[-STEP] ...), and
+	     ;; is not really the frame of what is about to be EVAL'd.
+	     ;; But we'd like to make it appear this way, so we check for
+	     ;; specially below.  (This subsumes the old "/" command.)
+
+	     ((= $command-show-frame command-char)
+	      (cond
+	       ((and (= command-arg 1) (> numbargs 0))
+			      ; If we broke, first frame is not really a frame,
+			      ;  but is the DIDL-Evalhook or DIDL-Evalhook-Step
+			      ;  frame.  But make it look like a real frame.
+		(setq current-sx broke-at-sx)
+		(let ((ht-entry (ht-find current-sx)))
+		     (setq current-function (2nd ht-entry))
+		     (setq current-loc (3rd ht-entry)))
+		(cond
+		 ((null current-loc)
+		  (setq current-screen nil)
+		  (setq current-screen-type 'no-screen)
+		  (setq force-redisplay t))
+		 (t
+		  (setq current-screen (get current-function 'didl-screen))
+		  (setq current-screen-type 'user-function-screen)
+		  (setq current-pos (loc^begin-pos current-loc)))))
+	      (frame-array
+		(setq current-sx (3rd current-frame))
+		(let ((ht-entry (ht-find current-sx)))
+		     (setq current-function (2nd ht-entry))
+		     (setq current-loc (3rd ht-entry)))
+		(cond
+		 ((null current-loc)
+		  (setq current-screen nil)
+		  (setq current-screen-type 'no-screen)
+		  (setq force-redisplay t))
+		 (t
+		  (setq current-screen (get current-function 'didl-screen))
+		  (setq current-screen-type 'user-function-screen)
+		  (setq current-pos (loc^begin-pos current-loc)))))
+	       (t
+		(didl-error '|No frame to show.|))))
+
+;;; Moving-around commands.
+
+
+	     ;; Move forward one or several left parens, ignoring the
+	     ;; structure of the code.
+
+	     ((= $command-into-sx command-char)
+	      (cond
+	       ((eq current-screen-type 'user-function-screen)
+		(setq current-loc (screen-go-into-sx current-screen
+						     current-loc
+						     command-arg))
+		(setq current-pos (loc^begin-pos current-loc))
+		(setq current-sx (leftparenloc^sx current-loc)))
+	       (t
+		(didl-error '|Not looking at a user function.|))))
+
+
+	     ;; Move backward one or several left parens.
+
+	     ((= $command-out-of-sx command-char)
+	      (cond
+	       ((eq current-screen-type 'user-function-screen)
+		(setq current-loc (screen-go-out-of-sx current-screen
+						       current-loc
+						       command-arg))
+		(setq current-pos (loc^begin-pos current-loc))
+		(setq current-sx (leftparenloc^sx current-loc)))
+	       (t
+		(didl-error '|Not looking at a user function.|))))
+
+
+	     ;; Move forward one or several left parens on the same
+	     ;; structural level as the current sx, if in a
+	     ;; user-function-screen.  If looking at frames, go deeper
+	     ;; one or several frames.
+
+	     ((= $command-next command-char)
+	      (cond
+	       ((eq current-screen-type 'user-function-screen)
+		(setq current-loc (screen-next-sx current-screen
+						  current-loc
+						  command-arg))
+		(setq current-pos (loc^begin-pos current-loc))
+		(setq current-sx (leftparenloc^sx current-loc)))
+	       ((eq current-screen-type 'frame-screen)
+		(setq current-pos
+		      (list (force-into-range 1 how-many-frames
+					      (+ current-frame-number
+						 command-arg))
+			    1)))
+	       (t
+		(didl-error '|Not looking at frames or a user function.|))))
+
+
+	     ;; Move backward one or several left parens on this level,
+	     ;; if looking at a user-function-screen.  If looking at frames,
+	     ;; go up one or more frames.
+
+	     ((= $command-previous command-char)
+	      (cond
+	       ((eq current-screen-type 'user-function-screen)
+		(setq current-loc (screen-previous-sx current-screen
+						      current-loc
+						      command-arg))
+		(setq current-pos (loc^begin-pos current-loc))
+		(setq current-sx (leftparenloc^sx current-loc)))
+	       ((eq current-screen-type 'frame-screen)
+		(setq current-pos
+		      (list (force-into-range 1 how-many-frames
+					      (- current-frame-number
+						 command-arg))
+			    1)))
+	       (t
+		(didl-error '|Not looking at frames or a user function.|))))
+
+
+	     ;; Select and display a user function.
+
+	     ((= $command-examine-user-function command-char)
+	      (let ((func (echo-area-prompt-and-read '|Function: |)))
+		   (cond
+		    ((user-function func)
+		     (put-defun-if-necessary func)
+		     (setq current-screen (get func 'didl-screen))
+		     (setq current-screen-type 'user-function-screen)
+		     (setq current-loc (get func 'didl-toploc))
+		     (setq current-function func)
+		     (setq current-sx (leftparenloc^sx current-loc))
+		     (setq current-pos (loc^begin-pos current-loc)))
+		    (t
+		     (didl-error '|Not a user function.|)))))
+
+
+	     ;;  Force a user function to be ground, though not displayed.
+
+	     ((= $command-grind-function command-char)
+	      (let ((func (echo-area-prompt-and-read '|Function: |)))
+		   (if (user-function func)
+		       (put-defun func)
+		       (didl-error '|Not a user function.|))))
+
+
+;;; Manipulating frame values.
+
+
+	     ;; Do an EVAL in the environment of the current frame,
+	     ;; if there is one, or just do an EVAL if there isn't.
+
+	     ((= $command-evaluate-in-frame command-char)
+	      (let ((what-to-eval (echo-area-prompt-and-read '|Evaluate: |)))
+		   (if frame-array
+		       (echo-area-print
+			(car (errset (evalhook what-to-eval
+					       (4th current-frame)
+					       (function didl-evalhook)))))
+		       (echo-area-print
+			(car (errset (evalhook what-to-eval
+					       (function didl-evalhook))))))
+		   (echo-area-terpri)))
+
+
+	     ;; Force a return from the current frame, returning a
+	     ;; given value.
+
+	     ((= $command-force-return-from-frame command-char)
+	      (let ((what-to-return (echo-area-prompt-and-read '|Return: |)))
+		   (cond
+		    (frame-array
+		     (setq what-to-return (errset (eval what-to-return
+							(4th current-frame))))
+		     (if what-to-return
+			 (freturn (2nd current-frame) (car what-to-return))
+			 (didl-error '|Error while eval'ing value.|)))
+		    (t
+		     (didl-error '|Nothing to return to.|)))))
+
+;;; Stepping-type commands.
+
+
+	     ;; Continue from where we broke.
+
+	     ((= $command-continue command-char)
+	      (cond
+	       (broke-at-frame				; Did we really break?
+		(return (evalhook (if (and broke-at-breakpoint
+					   (breakpoint^patch-enable
+					    broke-at-breakpoint))
+				      (breakpoint^patch broke-at-breakpoint)
+				      broke-at-sx)	; Do breakpoint patch
+							;  if it has one.
+   ;;;doesn't work		       (4th broke-at-frame)
+				  (function didl-evalhook))))
+	       (t
+		(didl-error '|Nothing to continue.|))))
+
+
+	     ;; Continue from where we broke, but display the eventual
+	     ;; value of the form we broke on.
+
+	     ((= $command-show-value command-char)
+	      (cond
+	       (broke-at-frame
+		(vars (value)
+		      (setq value
+			    (evalhook (if (and broke-at-breakpoint
+					       (breakpoint^patch-enable
+						broke-at-breakpoint))
+					  (breakpoint^patch broke-at-breakpoint)
+					  broke-at-sx)
+   ;;; doesn't work		   (4th broke-at-frame)
+				      (function didl-evalhook)))
+
+		      ;; Must redisplay, since much may have happened
+		      ;; in the meantime.
+
+		      (didl-redisplay current-screen current-screen-type
+				      current-pos current-sx current-function
+				      force-redisplay current-frame-number
+				      how-many-frames)
+		      (setq force-redisplay nil)
+		      (setq $last-screen current-screen)
+		      (setq $last-screen-type current-screen-type)
+		      (setq $last-pos current-pos)
+		      (and current-screen
+			   (setq current-screen-length
+				 (arrayget current-screen 0)))
+		      (info-area-clear)
+		      (info-area-princ '|Returned: |)
+		      (info-area-prin1t value)
+		      (info-area-princ '|--Continue--|)
+		      (window-set-cursor-with-pos $last-top-window-line
+						  current-pos)
+		      (tyi)
+		      (return value)))
+	       (t
+		(didl-error '|Nothing to continue.|))))
+
+
+	     ;; Continue from where we broke, but enable DIDL-Evalhook-Step
+	     ;; so we'll break on deeper EVAL's.  Eventually, show the value
+	     ;; of the form we broke on.
+
+	     ((= $command-step-deeper command-char)
+	      (cond
+	       (broke-at-frame
+		(vars (value)
+		      (setq value
+			    (evalhook (if (and broke-at-breakpoint
+					       (breakpoint^patch-enable
+						broke-at-breakpoint))
+					  (breakpoint^patch broke-at-breakpoint)
+					  broke-at-sx)
+   ;;; doesn't work		  (4th broke-at-frame)
+				      (function didl-evalhook-step)))
+		      (didl-redisplay current-screen current-screen-type
+				      current-pos current-sx
+				      current-function force-redisplay
+				      current-frame-number how-many-frames)
+		      (setq force-redisplay nil)
+		      (setq $last-screen current-screen)
+		      (setq $last-screen-type current-screen-type)
+		      (setq $last-pos current-pos)
+		      (and current-screen
+			   (setq current-screen-length
+				 (arrayget current-screen 0)))
+		      (info-area-clear)
+		      (info-area-princ '|Returned: |)
+		      (info-area-prin1t value)
+		      (info-area-princ '|--Continue--|)
+		      (info-area-terpri)
+		      (window-set-cursor-with-pos $last-top-window-line
+						  current-pos)
+		 
+		      (tyi)
+		      (return value)))
+	       (t
+		(didl-error '|Nothing to continue.|))))
+
+;;; Breakpoint commands.
+
+	     ;; Breakpoint commands are all two letters, so enter here
+	     ;; and read the next letter.
+
+	     ((= $command-breakpoint command-char)
+	      (setq command-char (read-command-char))
+
+	      (cond
+
+	       ;; Set a breakpoint, and give it a default or a user-assigned
+	       ;; name.
+
+	       ((= $bkpt-command-set-breakpoint command-char)
+		(cond
+		 ((not (atom current-sx))
+		  (setq breakpoint
+			(breakpoint-enter current-sx current-function))
+		  (store-breakpoint^name
+		   breakpoint
+		   (echo-area-prompt-and-read-with-default
+		    (breakpoint^name breakpoint)
+		    '|Breakpoint name [type space for default name: |
+		    (breakpoint^name breakpoint)
+		    `|]: |))
+		  (info-area-clear)
+		  (info-area-princ '|Breakpoint set, named |)
+		  (info-area-prin1t (breakpoint^name breakpoint)))
+		 (t
+		  (didl-error '|Can't set a breakpoint now.|))))
+
+
+	       ;; Clear a breakpoint.
+
+	       ((= $bkpt-command-clear-breakpoint command-char)
+		(cond
+		 (breakpoint
+		  (let ((breakpoint-name
+			 (echo-area-prompt-and-read-with-default
+			  (breakpoint^name breakpoint)
+			  '|Breakpoint to clear [type space for default: |
+			  (breakpoint^name breakpoint)
+			  '|]: |)))
+		       (cond
+			((breakpoint-remove breakpoint-name)
+			 (and (eq breakpoint-name (breakpoint^name breakpoint))
+			      (setq breakpoint nil))
+			 (info-area-clear)
+			 (info-area-princ '|Breakpoint |)
+			 (info-area-prin1 breakpoint-name)
+			 (info-area-princt '| cleared.|))
+			(t
+			 (didl-error '|No breakpoint has that name.|)))))
+		 (t
+		  (didl-error '|No breakpoint to clear.|))))
+
+
+	       ;; Set an if on the current breakpoint, which must
+	       ;; be non-NIL for the breakpoint to force a break.  If
+	       ;; command-arg is negative, disable the if,
+	       ;; which will force a break always.  Prompting for an if
+	       ;; defaults to the old if.
+
+	       ((= $bkpt-command-set-if command-char)
+		(cond
+		 ((not (atom current-sx))
+		  (setq breakpoint
+			(breakpoint-enter current-sx current-function))
+		  (cond
+		   ((< command-arg 0)
+		    (store-breakpoint^if-enable breakpoint nil)
+		    (info-area-clear)
+		    (info-area-princ '|Disabled if on breakpoint |)
+		    (info-area-princt (breakpoint^name breakpoint)))
+		   (t
+		    (store-breakpoint^if
+		     breakpoint
+		     (echo-area-prompt-and-read-with-default
+		      (breakpoint^if breakpoint)
+		      (breakpoint^name breakpoint)
+		      '| If [type space for old if]:  |))
+		    (store-breakpoint^if-enable breakpoint t))))
+		 (t
+		  (didl-error '|Can't set a breakpoint now.|))))
+
+	       ;; Set an action on the current breakpoint, which will always
+	       ;; be EVAL'd, even if the breakpoint does not break.  If
+	       ;; command-arg is negative, disable the action.
+	       ;; The prompt for an action defaults to the old action.
+
+	       ((= $bkpt-command-set-action command-char)
+		(cond
+		 ((not (atom current-sx))
+		  (setq breakpoint
+			(breakpoint-enter current-sx current-function))
+		  (cond
+		   ((< command-arg 0)
+		    (store-breakpoint^action-enable breakpoint nil)
+		    (info-area-clear)
+		    (info-area-princ '|Disabled action on breakpoint |)
+		    (info-area-princt (breakpoint^name breakpoint)))
+		   (t
+		    (store-breakpoint^action
+		     breakpoint
+		     (echo-area-prompt-and-read-with-default
+		      (breakpoint^action breakpoint)
+		      (breakpoint^name breakpoint)
+		      '| Action [type space for old action]: |))
+		    (store-breakpoint^action-enable breakpoint t))))
+		 (t
+		  (didl-error '|Can't set a breakpoint now.|))))
+
+
+	       ;; Set a patch on the current breakpoint, which will be
+	       ;; EVAL'd INSTEAD of the sx the breakpoint is set on, when
+	       ;; the breakpoint is hit.  If command-arg is negative, disable
+	       ;; the patch.  The prompt for the patch defaults to the
+	       ;; old patch.
+
+	       ((= $bkpt-command-set-patch command-char)
+		(cond
+		 ((not (atom current-sx))
+		  (setq breakpoint
+			(breakpoint-enter current-sx current-function))
+		  (cond
+		   ((< command-arg 0)
+		    (store-breakpoint^patch-enable breakpoint nil)
+		    (info-area-clear)
+		    (info-area-princ '|Disabled patch on breakpoint |)
+		    (info-area-princt (breakpoint^name breakpoint)))
+		   (t
+		    (store-breakpoint^patch
+		     breakpoint
+		     (echo-area-prompt-and-read-with-default
+		      (breakpoint^patch breakpoint)
+		      (breakpoint^name breakpoint)
+		      '| Patch [type space for old patch]: |))
+		    (store-breakpoint^patch-enable breakpoint t))))
+		 (t
+		  (didl-error '|Can't set a breakpoint now.|))))
+
+
+
+	       ;; List all the breakpoints on the $breakpoint-list.
+
+	       ((= $bkpt-command-list-all-breakpoints command-char)
+		(window-clear-line 1)
+		(window-princ '|Breakpoints:|)
+		(window-terpri)
+		(mapc (function
+		       (lambda (pair)
+			       (window-prin1 (breakpoint^name (cdr pair)))
+			       (window-princ '|  in |)
+			       (window-prin1 (breakpoint^function (cdr pair)))
+			       (window-terpri)))
+		      $breakpoint-list)
+		(or $breakpoint-list
+		    (window-princ '|No breakpoints have been set|)
+		    (window-terpri)))
+
+
+	       ;; Give the name, condition, action, and patch of the
+	       ;; current breakpoint.
+
+	       ((= $bkpt-command-tell-about-breakpoint command-char)
+		(cond
+		 (breakpoint
+		  (window-clear-line 1)
+		  (window-princ (breakpoint^name breakpoint))
+		  (window-princ '|: in |)
+		  (window-prin1 (breakpoint^function breakpoint))
+		  (window-terpri)
+		  (or (breakpoint^if-enable breakpoint)
+		      (window-princ '|[Disabled] |))
+		  (window-princ '|If: |)
+		  (window-prin1 (breakpoint^if breakpoint))
+		  (window-terpri)
+		  (or (breakpoint^action-enable breakpoint)
+		      (window-princ '|[Disabled] |))
+		  (window-princ '|Action: |)
+		  (window-prin1 (breakpoint^action breakpoint))
+		  (window-terpri)
+		  (or (breakpoint^patch-enable breakpoint)
+		      (window-princ '|[Disabled] |))
+		  (window-princ '|Patch: |)
+		  (window-prin1 (breakpoint^patch breakpoint))
+		  (window-terpri))
+		 (t
+		  (didl-error '|No current breakpoint.|))))
+
+
+	       ;; Ask for a breakpoint name from the user, and display
+	       ;; the user function in which the breakpoint is set,
+	       ;; pointing to where the breakpoint is set.
+
+	       ((= $bkpt-command-goto-breakpoint command-char)
+		(do ((name (echo-area-prompt-and-read '|Breakpoint name: |))
+		     (ht-entry)
+		     (bkpts $breakpoint-list (cdr bkpts)))
+		    ((null bkpts)
+		     (didl-error '|No such breakpoint.|))
+		    (and (eq name (breakpoint^name (cdar bkpts)))
+			 (progn
+			  (setq current-sx (caar bkpts))
+			  (setq ht-entry (ht-find current-sx))
+			  (setq current-function (2nd ht-entry))
+			  (setq current-loc (3rd ht-entry))
+			  (setq current-pos (loc^begin-pos current-loc))
+			  (setq current-screen
+				(get current-function 'didl-screen))
+			  (setq breakpoint (cdar bkpts))
+			  (setq current-screen-type 'user-function-screen)
+			  (return nil)))))
+
+
+	       ;; The user typed an unknown second letter for a breakpoint
+	       ;; command.
+
+	       (t
+		(didl-error '|Not a breakpoint command.|))))
+
+;;; When-condition commands.
+
+	     ;; When-condition commands are all two letters, so enter here
+	     ;; and read the next letter.
+
+	     ((= $command-when command-char)
+	      (setq command-char (read-command-char))
+
+	      (cond
+
+	       ;; Operate on the global when-condition.
+
+	       ((= $when-command-global command-char)
+		(cond
+		 ((< command-arg 0)
+		  (setq $global-when-condition-enable nil)
+		  (info-area-clear)
+		  (info-area-princt '|Disabled global when-condition |))
+		 (t
+		  (setq $global-when-condition
+			(echo-area-prompt-and-read-with-default
+			 $global-when-condition
+			 '|Global when-condition [type space for old one]: |))
+		  (setq $global-when-condition-enable t))))
+
+
+	       ;; Operate on the local when-condition.
+
+	       ((= $when-command-local command-char)
+		(cond
+		 ((< command-arg 0)
+		  (setq $local-when-condition-enable nil)
+		  (info-area-clear)
+		  (info-area-princt '|Disabled local when-condition |))
+		 (t
+		  (setq $local-when-condition
+			(echo-area-prompt-and-read-with-default
+			 $local-when-condition
+			 '|Local when-condition [type space for old one]: |))
+		  (setq $local-when-condition-enable t))))
+
+
+	       ;; Tell about the global and local when-conditions.
+
+	       ((= $when-command-tell-about-when-conditions command-char)
+		(window-clear-line 1)
+		(or $local-when-condition-enable
+		    (window-princ '|[Disabled] |))
+		(window-princ '|Local when-condition: |)
+		(window-prin1 $local-when-condition)
+		(window-terpri)
+		(or $global-when-condition-enable
+		    (window-princ '|[Disabled] |))
+		(window-princ '|Global when-condition: |)
+		(window-prin1 $global-when-condition)
+		(window-terpri))
+	       
+	       (t
+		(didl-error '|Not a when-condition command.|))))
+
+;;; Miscellaneous commands.
+
+
+	     ;; The Help command displays libdoc;didl help.
+
+	     ((= $command-help command-char)
+	      (let ((help-file (open '((dsk libdoc) didl help) 'in)))
+		   (window-clear)
+		   (do ((char (tyi help-file -1) (tyi help-file -1)))
+		       ((= char -1)
+			(window-terpri)
+			(window-princ '|End of help.  --Redisplay--|)
+			(close help-file))
+		       (or (member char '(14 3))
+			   (window-tyo char))))
+	      (tyi)
+	      (setq force-redisplay t))
+
+
+	     ;; Quit from DIDL, enabling DIDL-Evalhook.
+
+	     ((= $command-quit command-char)
+	      (eval '(setq evalhook (function didl-evalhook)) nil)
+	      (unsplit-screen)
+	      (return 'QUIT-FROM-DIDL))
+
+	     
+	     ;; Ignore certain characters.
+
+	     ((memq command-char $command-chars-to-ignore))
+
+
+	     ;; All other characters are errors.
+
+	     (t
+	      (didl-error '||)
+	      (tyo 7)))
+
+	    abort-command))
+	  (progn
+	   (echo-area-clear)
+	   (didl-error '|Command aborted.|)))
+	  ;End of catch for aborting commands
+	 ))
+       (unsplit-screen)))
+
+
+;;; DIDL-Evalhook is the evalhook function, which looks at every call
+;;; to eval when it is enabled.  It calls didl if we're stepping or a
+;;; breakpoint has been hit.  The call to didl returns with the value
+;;; of the form.
+
+(defun didl-evalhook (form)
+       (let ((breakpoint (assq form $breakpoint-list)))
+	    (cond
+	     ((and $local-when-condition-enable
+		   (car (errset (eval $local-when-condition) nil)))
+	      (didl '$local-when-condition form))
+	     ((and $global-when-condition-enable
+		   (car (errset (eval $global-when-condition) nil)))
+	      (didl '$global-when-condition form))
+	     (breakpoint				; We hit a breakpoint.
+	      (setq breakpoint (cdr breakpoint))
+	      (and (breakpoint^action-enable breakpoint)
+		   (eval (breakpoint^action breakpoint)))
+	      (let ((should-break (if (breakpoint^if-enable breakpoint)
+				      (eval (breakpoint^if breakpoint))
+				      t)))
+		   (cond			; Eval patch if there is one.
+		    ((breakpoint^patch-enable breakpoint)
+		     (and should-break
+			  (didl 'breakpoint form breakpoint))
+		     (eval (breakpoint^patch breakpoint)))
+		    (t
+		     (if should-break
+			 (didl 'breakpoint form breakpoint)
+			 (evalhook form (function didl-evalhook)))))))
+
+	     ;; No breakpoint, so just continue.
+
+	     (t
+	      (evalhook form (function didl-evalhook))))))
+
+;;; Didl-Evalhook-Step is for single-stepping, and always calls
+;;; didl before evaluating a form.  But it does check for breakpoints
+;;; first.
+
+(defun didl-evalhook-step (form)
+       (let ((breakpoint (assq form $breakpoint-list)))
+	    (cond
+	     ((and $local-when-condition-enable
+		   (car (errset (eval $local-when-condition) nil)))
+	      (didl '$local-when-condition form))
+	     ((and $global-when-condition-enable
+		   (car (errset (eval $global-when-condition) nil)))
+	      (didl '$global-when-condition form))
+	     (breakpoint
+	      (setq breakpoint (cdr breakpoint))
+	      (eval (breakpoint^action breakpoint))
+	      (let ((should-break (if (breakpoint^if-enable breakpoint)
+				      (eval (breakpoint^if breakpoint))
+				      t)))
+		   (cond
+		    ((breakpoint^patch-enable breakpoint)
+		     (and should-break
+			  (didl 'breakpoint form breakpoint))
+		     (eval (breakpoint^patch breakpoint)))
+		    (t
+		     (if should-break
+			 (didl 'breakpoint form breakpoint)
+			 (evalhook form (function didl-evalhook)))))))
+
+	     ;; Break to DIDL, since we're stepping.
+
+	     (t
+	      (didl 'stepping form)))))
+
+
+;;; DStep is to be called by the user.  It is for stepping a form from
+;;; the beginning, without entering DIDL first.
+
+(defun dstep (form)
+       (evalhook form (function didl-evalhook-step)))
+
+
+;;; Enter-DIDL is the interrupt function put on Control-E.  It effectively
+;;; does "(didl)".
+
+(defun enter-didl (tty char)
+       (nointerrupt nil)
+       (tyi tty)
+       (print (didl))
+       (terpri))
+
+;;; DIDL-Redisplay compares $last-screen, etc. with its arguments, to
+;;; determine if a redisplay should be done.
+
+(defun didl-redisplay (current-screen current-screen-type current-pos
+		       current-sx current-function force-redisplay
+		       current-frame-number how-many-frames)
+       (vars (old-top-window-line)
+	     (cond
+	      ((not (eq current-screen-type 'no-screen))
+	       (setq old-top-window-line $last-top-window-line)
+	   
+	       (cond
+		((or force-redisplay (not (eq current-screen $last-screen)))
+		 (setq $last-top-window-line
+		       (window-redisplay current-screen (1st current-pos))))
+		(t (setq $last-top-window-line
+			 (window-redisplay-if-necessary current-screen
+							$last-top-window-line
+							(1st current-pos)))))
+	   
+	       (and (or force-redisplay
+			(not (eq current-screen $last-screen))
+			(not (equal old-top-window-line
+				    $last-top-window-line)))
+
+		    ;; Set up status line and display what needs to
+		    ;; be displayed.
+
+		    (cond
+		     ((eq current-screen-type 'user-function-screen)
+			  (window-set-status-line
+			   current-function
+			   '|  (Frame #| current-frame-number
+			   '|)  [Top line: | $last-top-window-line
+			   (cond
+			    ((= $last-top-window-line 1)
+			     (if
+			      (<= (arrayget current-screen 0)
+				  (+ $last-top-window-line $window-length -1))
+			      '| ]  --All--|
+			      '| ]  --Top--|))
+			    ((> (arrayget current-screen 0)
+			     (+ $last-top-window-line $window-length -1))
+			     '| ]  --Middle--|)
+			    (t
+			     '| ]  --Bottom--|)))
+		      (window-display-status-line))
+		     ((eq current-screen-type 'frame-screen)
+		      (window-set-status-line '|Frame display  [|
+					    how-many-frames '| frames]|)
+		      (window-display-status-line))))
+	   
+	       (window-set-cursor-with-pos $last-top-window-line current-pos))
+	  
+	      (force-redisplay
+	       (cond
+		((and (atom current-sx) (not (null current-sx)))
+		 (window-clear-and-print current-sx)
+		 (window-set-status-line '|Atom|)
+		 (window-display-status-line))
+		(current-sx
+		 (window-clear-and-print current-sx)
+		 (window-set-status-line '|Non-user-form|)
+		 (window-display-status-line))
+		(t
+		 (window-clear)
+		 (window-set-status-line 'DIDL)
+		 (window-display-status-line)))))))
+
+
+;;; DIDL-Error reports the error in the echo area.
+
+(defun didl-error (error-message)
+       (info-area-clear)
+       (tyo 7)
+       (info-area-princ error-message))
+
+;;; Functions for adding and removing breakpoints from $breakpoint-list.
+
+;;; Breakpoint-Enter looks for a breakpoint for the given sx on
+;;; $breakpoint-list.  It returns that breakpoint if found, otherwise
+;;; it creates a fresh new breakpoint.
+
+(defun breakpoint-enter (sx function)
+       (cond
+	((cdr (assq sx $breakpoint-list)))
+	(t
+	 (let ((breakpoint (create-breakpoint)))
+	      (push (cons sx breakpoint) $breakpoint-list)
+	      (store-breakpoint^name breakpoint (breakpoint-new-name))
+	      (store-breakpoint^function breakpoint function)
+	      (store-breakpoint^if-enable breakpoint nil)
+	      (store-breakpoint^if breakpoint t)
+	      (store-breakpoint^action-enable breakpoint nil)
+	      (store-breakpoint^action breakpoint nil)
+	      (store-breakpoint^patch-enable breakpoint nil)
+	      (store-breakpoint^patch breakpoint nil)
+	      breakpoint))))
+
+
+;;; Breakpoint-Remove splices the breakpoint entry of the breakpoint with the
+;;; name breakpoint-name out of $breakpoint-list.
+;;; If there is no breakpoint by that name, Breakpoint-Remove returns nil;
+;;; if it succeeds, it returns t.
+
+(defun breakpoint-remove (breakpoint-name)
+       (do ((rest $breakpoint-list (cdr rest)))
+	   ((null rest) nil)
+	   (cond
+	    ((eq breakpoint-name (breakpoint^name (cdr (1st rest))))
+	     (setq $breakpoint-list (delq (1st rest) $breakpoint-list))
+	     (return t)))))
+
+
+;;; Breakpoint-New-Name generates a new interned name for a breakpoint.
+
+(defun breakpoint-new-name ()
+       (let ((base 10.) (*nopoint t))
+	    (implode (append '(B P T) (explode (setq $unique-number
+						     (1+ $unique-number)))))))
+
+;;; Functions for moving around in screens, using locs.
+
+
+;;; Screen-Go-Into-SX tries to go into the next non-atomic sx.
+;;; It scans forward from the current-loc, looking for a marker
+;;; containing a leftparenloc.  If it finds one, it stops at the next
+;;; loc after that.  If it doesn't find one, it doesn't move.
+;;; It returns the loc it stops at.
+;;; count indicates how many times to do this.  If count < 0, it will call
+;;; screen-go-out-of-sx instead.
+
+(defun screen-go-into-sx (screen current-loc count)
+       (if (< count 0)
+	   (screen-go-out-of-sx screen current-loc (- count))
+	   (catch
+	    (do ((i 1 (1+ i)))
+		((> i count) current-loc)
+		(do ((next-loc current-loc))
+		    (nil)
+		    (setq next-loc
+			  (screen-next-loc screen next-loc))
+		    (if (null next-loc)
+			(throw current-loc)
+			(and (eq (cdr next-loc) 'leftparenloc)
+			     (return (setq current-loc next-loc)))))))))
+
+
+;;; Screen-Go-Out-Of-SX searches backwards for a leftparenloc.
+
+(defun screen-go-out-of-sx (screen current-loc count)
+       (if (< count 0)
+	   (screen-go-into-sx screen current-loc (- count))
+	   (catch
+	    (do ((i 1 (1+ i)))
+		((> i count) current-loc)
+		(do ((previous-loc current-loc))
+		    (nil)
+		    (setq previous-loc
+			  (screen-previous-loc screen previous-loc))
+		    (if (null previous-loc)
+			(throw current-loc)
+			(and (eq (cdr previous-loc) 'leftparenloc)
+			     (return (setq current-loc previous-loc)))))))))
+
+;;; Screen-Next-SX searches forward from the end of the current-loc
+;;; (after its corresponding rightparenloc), looking for a leftparenloc.
+;;; If it doesn't find one, it stays where it was.
+
+(defun screen-next-sx (screen current-loc count)
+       (if (< count 0)
+	   (screen-previous-sx screen current-loc (- count))
+	   (catch
+	    (do ((i 1 (1+ i)))
+		((> i count) current-loc)
+		(do ((next-loc current-loc))
+		    (nil)
+		    (setq next-loc
+			  (screen-next-loc screen
+					   (cdr (screen-char-or-marker
+						 screen
+						 (loc^end-pos next-loc)))))
+		    (if (or (null next-loc) (eq (cdr next-loc) 'rightparenloc))
+			(throw current-loc)
+			(and (eq (cdr next-loc) 'leftparenloc)
+			     (return (setq current-loc next-loc)))))))))
+
+
+;;; Screen-Previous-SX searches backwards, looking for a leftparenloc,
+;;; skipping left parens at levels deeper than the current-loc.
+
+(defun screen-previous-sx (screen current-loc count)
+       (if (< count 0)
+	   (screen-next-sx screen current-loc (- count))
+	   (catch
+	    (do ((i 1 (1+ i)))
+		((> i count) current-loc)
+		(do ((previous-loc current-loc))
+		    (nil)
+		    (setq previous-loc
+			  (screen-previous-loc screen previous-loc))
+		    (if (or (null previous-loc) (eq (cdr previous-loc)
+						    'leftparenloc))
+			(throw current-loc)
+			(and (eq (cdr previous-loc) 'rightparenloc)
+			     (return
+			      (setq current-loc
+				    (cdr (screen-char-or-marker
+					  screen
+					  (rightparenloc^begin-pos
+					   previous-loc))))))))))))
+
+;;; Screen-Next-Loc returns the next loc it finds after current-loc.
+;;; It returns NIL if there is no next loc.
+
+(defun screen-next-loc (screen current-loc)
+       (do ((pos (screen-next-pos screen
+				  (if (eq (cdr current-loc) 'rightparenloc)
+				      (rightparenloc^end-pos current-loc)
+				      (leftparenloc^begin-pos current-loc)))
+		 (screen-next-pos screen pos))
+	    (char))
+	   ((null pos) nil)
+	   (setq char (screen-char-or-marker screen pos))
+	   (or (atom char)
+	       (return (cdr char)))))
+
+
+;;; Screen-Previous-Loc goes the other way.
+
+(defun screen-previous-loc (screen current-loc)
+       (do ((pos
+	     (screen-previous-pos screen
+				  (if (eq (cdr current-loc) 'rightparenloc)
+				      (rightparenloc^end-pos current-loc)
+				      (leftparenloc^begin-pos current-loc)))
+	     (screen-previous-pos screen pos))
+	    (char))
+	   ((null pos) nil)
+	   (setq char (screen-char-or-marker screen pos))
+	   (or (atom char)
+	       (return (cdr char)))))
+
+
+;;; Screen-Next-Pos and Screen-Previous-Pos return the next meaningful
+;;; pos after/before current-pos.  They return NIL if there is none.
+
+(defun screen-next-pos (screen pos)
+       (let ((last-line-num (arrayget screen 0))
+	     (last-char-num (arrayget (arrayget screen (1st pos)) 0)))
+	    (if (< (2nd pos) last-char-num)
+		(list (1st pos) (1+ (2nd pos)))
+		(if (< (1st pos) last-line-num)
+		    (list (1+ (1st pos)) 1)
+		    nil))))
+
+(defun screen-previous-pos (screen pos)
+       (if (> (2nd pos) 1)
+	   (list (1st pos) (1- (2nd pos)))
+	   (if (> (1st pos) 1)
+	       (list (1- (1st pos))
+		     (arrayget (arrayget screen (1- (1st pos))) 0))
+	       nil)))
+
+
+;;; Screen-Char-Or-Marker, unlike Line-Char, returns exactly what is at pos.
+
+(defun screen-char-or-marker (screen pos)
+       (arrayget (arrayget screen (1st pos)) (2nd pos)))
+
+;;; Functions for stack frame operations.
+
+;;; Framearray returns an array of results from evalframe, starting at
+;;; first-frame-to-use.  It returns NIL if there are no frames.
+;;; Frame indexing starts at 1; (arrayget frame-array 0) is how many
+;;; frames there are.
+;;; Occurrences of DIDL, Enter-DIDL,
+;;; EVALHOOK and +INTERNAL-TTYSCAN-SUBR are deleted.
+;;; Occurrences of DIDL-Evalhook and DIDL-Evalhook step are also deleted,
+;;; except if they would be the first entries in the frame array.
+
+(defun framearray (first-frame-to-use)
+       (do ((frame-list)
+	    (frame-list-length 0)
+	    (frame first-frame-to-use (evalframe (2nd frame)))
+	    (form))
+	   ((null frame)
+	    (if (null frame-list)
+		nil
+		(fillarray (newarray (1+ frame-list-length))
+			   (cons frame-list-length
+				 (nreverse frame-list)))))
+	   (setq form (3rd frame))
+	   (cond
+	    ((and (not (atom form))
+		  (or (memq (car form)
+			    '(didl evalhook enter-didl +internal-ttyscan-subr))
+		      (and (not (= frame-list-length 0))
+			   (memq (car form)
+				 '(didl-evalhook didl-evalhook-step))))))
+	    (t
+	     (setq frame-list-length (1+ frame-list-length))
+	     (push frame frame-list)))))
+
+
+;;; Put-Frame-Array-User-Functions scans the whole frame-array, and
+;;; Puts the user functions it finds, if they haven't been Put already.
+
+(defun put-frame-array-user-functions (frame-array)
+       (do ((last-frame (arrayget frame-array 0))
+	    (frame-form)
+	    (frame-index 1 (1+ frame-index)))
+	   ((> frame-index last-frame))
+	   (setq frame-form (3rd (arrayget frame-array frame-index)))
+	   (and (not (atom frame-form))
+		(user-function (car frame-form))
+		(put-defun-if-necessary (car frame-form)))))
+
+
+;;; Find-User-Frame starting at start-at in frame-array, and searches
+;;; upwards or downwards, depending on inc,
+;;; looking for a form that is in a user function.
+;;; It returns an index into frame-array, or NIL if no user function was found.
+
+(defun find-user-frame (frame-array start-at inc)
+       (do ((last-frame (arrayget frame-array 0))
+	    (frame-index start-at (+ inc frame-index)))
+	   ((or (> frame-index last-frame) (< frame-index 1)) nil)
+	   (and (ht-find (3rd (arrayget frame-array frame-index)))
+		(return frame-index))))
+
+
+;;; User-Function says if the function is an expr, fexpr, or macro.
+
+(defun user-function (func)
+       (and (symbolp func)
+	    (find-fun func)))	   ;find any DIDL-hackable functional property
+
+;;; Make-Frame-Screen creates a screen that has the information
+;;; of frame-array in it.
+;;; A frame-screen line looks like:
+;;; <frame number>: <user function>: <frame form> e.g.
+;;; 7: FUNC: (CAR FOO)
+;;; The <user function> may be blank if the <frame form> is not
+;;; found in $hash-table.  For instance, it may be an atom or a subr form.
+;;; (DIDL-EVALHOOK ...) and (DIDL-EVALHOOK-STEP ...) frames are special,
+;;; and look like:
+;;; 1: Broke at FUNC: (CAR FOO)
+;;; where (CAR FOO) is the frame that is ABOUT to be created.
+
+(defun make-frame-screen (frame-array)
+       (let ((how-many-frames (arrayget frame-array 0))
+	     (form) (in-what-func) (broke-at nil)
+	     (exploded-broke-at (exploden '|Broke at |))
+	     (frame-screen (newarray (cadr (arraydims frame-array)))))
+	    (arraystore frame-screen 0 how-many-frames)
+	    (for i 1 how-many-frames
+		 (setq broke-at nil)
+		 (arraystore frame-screen i (create-line))
+		 (setq form (3rd (arrayget frame-array i)))
+		 (and (not (symbolp form))
+		      (memq (car form) '(didl-evalhook didl-evalhook-step))
+		      (setq broke-at exploded-broke-at)
+		      (setq form (2nd form)))
+		 (if (setq in-what-func (2nd (ht-find form)))
+		     (stuff-line (arrayget frame-screen i)
+				 (explodendec i) '(72 40)             ;; ": "
+				 broke-at
+				 (exploden in-what-func) '(72 40)  ;; ": "
+				 (exploden form))
+		     (stuff-line (arrayget frame-screen i)
+				 (explodendec i) '(72 40)
+				 broke-at
+				 (exploden form))))
+	    frame-screen))
+
+;;; Utility functions for command readers.
+
+;;; Force-Into-Range forces a number into being in a certain range.
+;;; E.g.: (force-into-range 1 3 4) => 3.
+
+(defun force-into-range (low high num)
+       (max low (min high num)))
+
+
+;;; Read-Command-Arg tyipeek's to see if there is a digit present.
+;;; Ifso, it builds a decimal number from that and subsequent digits.
+;;; Ifnot, it returns 1.
+
+(defun read-command-arg ()
+       (do ((char (tyipeek) (tyipeek))
+	    (no-arg t)
+	    (neg 1)
+	    (argument 0))
+	   (nil)
+	   (cond
+	    ((and (<= char 71) (>= char 60))    ;a digit?
+	     (setq argument (+ (* argument 10.) (- char 60)))
+	     (setq no-arg nil))
+	    ((= char 55)
+	     (setq neg (- neg))			; a - ?
+	     (setq no-arg t))
+	    (t
+	     (return (* neg (if no-arg 1 argument)))))
+	   (tyi)))
+
+
+;;; Read-Command-Char inputs a char and uppercases it.
+
+(defun read-command-char ()
+       (let ((char (tyi)))
+	    (if (or (< char 141) (> char 172))
+		char
+		(- char 40))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Put- functions are for grinding s-expressions (sx's), and producing:
+;;; an array which is the printed representation of the result, and
+;;; containing markers which indicate where sx's are.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; Put-Defun-If-Necessary does a put-defun only if the function has
+;;; not already been put.
+
+(defun put-defun-if-necessary (func)
+       (or (and (get func 'didl-screen)
+		(ht-find (find-fun func)))
+	   (progn
+	    (echo-area-princ '|Grinding |)
+	    (echo-area-prin1 func)
+	    (put-defun func)
+	    (echo-area-princt '|.|))))
+
+;;; Find-Fun finds any functional that DIDL can print, or returns nil if none
+
+(defun find-fun (function)
+  (let ((function (cadr (getl function '(expr fexpr macro)))))
+     (cond ((null function) nil)
+	   ((symbolp function) (find-fun function))
+	   (t function))))
+
+;;; Put-Defun takes a function name, and produces the put-ground result, using
+;;;  lower functions.
+
+(defun put-defun (func)
+       (vars (screen sx)
+	     (setq sx (find-fun func))
+	     (and (atom sx) (error '|has no reasonable functional property|
+				   func))
+
+	     (setq screen (newarray 20.))		; can expand
+	     (arraystore screen 0 0)
+	     (putprop func (put-sx sx screen '(1 1) func) 'didl-toploc)
+	     (putprop func screen 'didl-screen)))
+
+;;; Put-SX looks at an sx, decides how it should be put, and calls the right
+;;; routine.
+
+(defun put-sx (sx screen pos in-function)
+       (vars (put-format)
+	     (cond
+
+	      ;; If an atom, just put it out.
+
+	      ((atom sx)  (put-atom sx screen pos))
+
+	      ;; If function wants to be put a special way, acquiesce.
+
+	      ((and (atom (car sx))
+		    (setq put-format (get (car sx) 'didl-put-format)))
+	       (cond
+		((eq put-format 'put-miser)
+		 (put-miser sx screen pos in-function))
+		((eq put-format 'put-block)
+		 (put-block sx screen pos in-function))
+		((eq put-format 'put-function-call)
+		 (put-function-call sx screen pos in-function))
+		(t (error '|does not have a legal DIDL-Put-Format|
+			  (car sx)))))
+
+	      ;; If it fits on a line, put it on one line.
+
+	      ((fits-on-line (flatsize sx) pos)
+	       (put-block sx screen pos in-function))
+
+	      ;; If it's a function, put it in function format.
+
+	      ((and (symbolp (car sx))
+		    (getl (car sx) '(subr fsubr lsubr expr fexpr macro)))
+	       (put-function-call sx screen pos in-function))
+
+	      ;; Else, put it in miser format.
+
+	      (t (put-miser sx screen pos in-function)))))
+
+;;; Put-Miser puts lists in the form:
+;;; (A
+;;;  B
+;;;  C)
+;;; It calls put-sx for each element of the list.
+;;; It puts markers at the left-paren and right-paren.
+
+(defun put-miser (sx screen start-pos in-function)
+       (vars
+	(leftparenloc rightparenloc
+	 ht-entry indent-column next-pos)
+
+	(setq ht-entry (ht-enter sx))
+	(setq leftparenloc (create-leftparenloc))
+	(setq rightparenloc (create-rightparenloc))
+	(rplacd ht-entry (list in-function leftparenloc))
+
+	(store-leftparenloc^begin-pos leftparenloc start-pos)
+	(store-rightparenloc^begin-pos rightparenloc start-pos)
+	(store-leftparenloc^sx leftparenloc sx)
+	(store-rightparenloc^sx rightparenloc sx)
+
+	(setq indent-column (2nd (setq next-pos (pos+1 start-pos))))
+	(putscreen-char screen start-pos (cons 50 leftparenloc))
+	(do ((sx-left sx (if (atom sx-left) nil (cdr sx-left)))
+	     (element) (element-loc) (atomic-cdrp) (last-elementp)
+	     (element-index 0 (1+ element-index)))
+
+	    ((null sx-left))
+
+	    ;; atomic-cdrp checks for (... . <atom>).
+
+	    (setq atomic-cdrp (atom sx-left))
+	    (setq element (if atomic-cdrp sx-left (car sx-left)))
+	    (setq last-elementp (or atomic-cdrp (null (cdr sx-left))))
+
+	    (and atomic-cdrp
+		 (progn
+		  (putscreen-char screen next-pos 56)	; period
+		  (setq next-pos (pos+1 (pos+1 next-pos)))))
+
+	    (setq element-loc (put-sx element screen next-pos in-function))
+
+	    (setq next-pos
+		  (if last-elementp
+		      (pos+1-with-indent (loc^end-pos element-loc)
+					 indent-column)
+		      (list (1+ (1st (loc^end-pos element-loc)))
+			    indent-column))))
+
+	(putscreen-char screen next-pos (cons 51 rightparenloc))
+	(store-leftparenloc^end-pos leftparenloc next-pos)
+	(store-rightparenloc^end-pos rightparenloc next-pos)
+
+	leftparenloc))
+
+;;; Put-Block puts lists in the form:
+;;; (A B C
+;;;  D E F)
+;;; by calling Put-Block-Indent with 0 indentation.
+
+(defun put-block (sx screen start-pos in-function)
+       (put-block-indent sx screen start-pos in-function 0))
+
+
+
+;;; Put-Function-Call puts lists in the form:
+;;; (FUNC A B C
+;;;    D E F)
+;;; by calling Put-Block-Indent with an indentation of 2.
+
+(defun put-function-call (sx screen start-pos in-function)
+       (put-block-indent sx screen start-pos in-function 2))
+
+;;; Put-Block-Indent puts lists in the form:
+;;; (A B C
+;;;  <indentation spaces>D E F)
+;;; It will wrap the first atom on a line onto the next line if necessary,
+;;; but not subsequent atoms or sx's.
+;;; It puts a marker for the sx when it puts the left-paren on the screen.
+
+(defun put-block-indent (sx screen start-pos in-function indentation)
+       (vars (leftparenloc rightparenloc
+	      ht-entry indent-column next-pos)
+	 
+	     (setq ht-entry (ht-enter sx))
+	     (setq leftparenloc (create-leftparenloc))
+	     (setq rightparenloc (create-rightparenloc))
+	     (rplacd ht-entry (list in-function leftparenloc))
+	 
+	     (store-leftparenloc^begin-pos leftparenloc start-pos)
+	     (store-rightparenloc^begin-pos rightparenloc start-pos)
+	     (store-leftparenloc^sx leftparenloc sx)
+	     (store-rightparenloc^sx rightparenloc sx)
+	 
+	     (setq indent-column (+ indentation
+				    (2nd (setq next-pos (pos+1 start-pos)))))
+	     (putscreen-char screen start-pos (cons 50 leftparenloc))
+	 
+	     (do ((sx-left sx (if (atom sx-left) nil (cdr sx-left)))
+		  (element) (element-loc) (atomic-cdrp) (last-elementp)
+		  (element-index 0 (1+ element-index)))
+
+		 ((null sx-left))
+
+		 (setq atomic-cdrp (atom sx-left))
+		 (setq element (if atomic-cdrp sx-left (car sx-left)))
+		 (setq last-elementp (or atomic-cdrp (null (cdr sx-left))))
+
+		 (and atomic-cdrp
+		      (progn
+		       (putscreen-char screen next-pos 56)	; period
+		       (setq next-pos
+			     (compute-next-block-pos indent-column next-pos
+						     next-pos
+						     (1+ (flatsize element)))))
+		      )
+
+		 (setq element-loc
+		       (put-sx element screen next-pos in-function))
+
+		 (setq next-pos
+		       (if last-elementp
+			   (pos+1-with-indent (loc^end-pos element-loc)
+					      (1+ indent-column))
+			   (compute-next-block-pos indent-column next-pos
+						   (loc^end-pos element-loc)
+						   (flatsize
+						    (if (atom (cdr sx-left))
+							(cdr sx-left)
+							(cadr sx-left)))))))
+	 
+	 
+	     (putscreen-char screen next-pos (cons 51 rightparenloc))
+	     (store-leftparenloc^end-pos leftparenloc next-pos)
+	     (store-rightparenloc^end-pos rightparenloc next-pos)
+	 
+	     leftparenloc))
+
+;;; Compute-Next-Block-Pos sees if what is to be printed will fit on the
+;;; current line.  Ifso, it returns a pos of where to start printing on the
+;;; line, including the necessary space before.  Ifnot, it returns a pos that
+;;; is at the proper indentation on the next line.  It also forces printing
+;;; on the next line if the previous form was not completely put on the same
+;;; line.
+;;; start-pos and end-pos are where the last form was put.
+
+(defun compute-next-block-pos (indent-column start-pos end-pos size)
+       (if (and (fits-on-line (+ 2 size) end-pos)
+		(= (1st start-pos) (1st end-pos)))
+	   (list (1st end-pos) (+ 2 (2nd end-pos)))
+	   (list (1+ (1st end-pos)) indent-column)))
+
+
+;;; Put-Atom puts the chars that are in an atom's pname onto the screen,
+;;; starting at pos.
+
+(defun put-atom (the-atom screen pos)
+       (let ((atomloc (create-atomloc)))
+	    (store-atomloc^begin-pos atomloc pos)
+	    (store-atomloc^the-atom atomloc the-atom)
+	    (do ((chars (explode the-atom) (cdr chars))
+		 (next-pos pos (pos+1 next-pos))
+		 (first t nil)
+		 (last-pos pos next-pos))
+		((null chars)
+		 (store-atomloc^end-pos atomloc last-pos)
+		 atomloc)
+		(putscreen-char screen next-pos (getcharn (car chars) 1)))))
+
+
+;;; Putscreen-char grows the screen if necessary, and then calls putline-char.
+
+(defun putscreen-char (screen pos char)
+       (let ((screen-length (1- (cadr (arraydims screen)))))
+	     (and (> (1st pos) screen-length)
+		  (*rearray screen t (+ (1st pos) screen-length)))
+	     (putline-char screen pos char)))
+
+
+;;; Putline-Char actually does the storing on the line array, and also updates
+;;; the last-line-used (arrayget screen 0) and last-char-used
+;;; (arrayget <line> 0) indices.  It creates a new line array if there was
+;;; not one in the screen array, and fills it with spaces.
+
+(defun putline-char (screen pos char)
+       (let ((line (1st pos))
+	     (col (2nd pos))
+	     (line-array))
+	    (setq line-array (arrayget screen line))
+	    (cond
+	     ((null line-array)
+	      (arraystore screen line (setq line-array (create-line)))
+	      (for i 1 $screen-width (arraystore line-array i 40)))) ;space
+	    (arraystore line-array col char)
+	    (arraystore line-array 0 (max (arrayget line-array 0) col))
+	    (arraystore screen 0 (max (arrayget screen 0) line))))
+
+;;; Line-Char fetches a char from a line, taking it out of a marker
+;;; if necessary.
+
+(defun line-char (line index)
+       (let ((char-or-marker (arrayget line index)))
+	    (if (atom char-or-marker)
+		char-or-marker
+		(car char-or-marker))))
+
+
+;;; Loc^Begin-Pos looks like a structure ref, but really sees what kind of
+;;; loc it is given, and then fetches the right Begin-Pos.
+;;; Loc^End-Pos is similar.
+
+(defun loc^begin-pos (loc)
+       (cond
+	((eq (cdr loc) 'leftparenloc) (leftparenloc^begin-pos loc))
+	((eq (cdr loc) 'rightparenloc) (rightparenloc^begin-pos loc))
+	((eq (cdr loc) 'atomloc) (atomloc^begin-pos loc))
+	(t (error '|is not a loc [loc^begin-pos]| loc))))
+
+(defun loc^end-pos (loc)
+       (cond
+	((eq (cdr loc) 'leftparenloc) (leftparenloc^end-pos loc))
+	((eq (cdr loc) 'rightparenloc) (rightparenloc^end-pos loc))
+	((eq (cdr loc) 'atomloc) (atomloc^end-pos loc))
+	(t (error '|is not a loc [loc^end-pos]| loc))))
+
+
+;;; Fits-On-Line says whether there is room on the rest of a line for
+;;; something of a given size.  It assumes starting at pos.
+
+(defun fits-on-line (size pos)
+       (not (> (+ size (2nd pos) -1) $screen-width)))
+
+
+;;; Create-Line creates a new array of length $screen-width+1, and stores
+;;; 0 in its 0th element, to create a blank line.
+
+(defun create-line ()
+       (let ((line (newarray (1+ $screen-width))))
+	    (arraystore line 0 0)
+	    line))
+
+
+;;; Pos+1-with-indent adds 1 column to a pos, wrapping onto the next line if
+;;; necessary, and indenting to indent-column.
+
+(defun pos+1-with-indent (pos indent-col)
+       (if (>= (2nd pos) $screen-width)
+	   (list (1+ (1st pos)) indent-col)
+	   (list (1st pos) (1+ (2nd pos)))))
+
+;;; Pos+1 wraps to the left side of the next line by using an indent-col of 1.
+
+(defun pos+1 (pos)
+       (pos+1-with-indent pos 1))
+
+
+
+;;; Debugging functions for dumping a screen.
+
+(defun dump-screen (screen)
+       (for line 1 (arrayget screen 0)
+	    (terpri)
+	    (let ((line-array (arrayget screen line)))
+		 (if (null line-array)
+		     (princ nil)
+		     (for col 1 (arrayget line-array 0)
+			  (tyo (line-char line-array col)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Hash table functions for DIDL.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; The HT (hash table) is used for finding the loc of a particular
+;;; sx.  The hashing is on (maknum sx), which is faster than (sxhash sx).
+
+;;; The HT is an array with a prime number of elements (for good hashing).
+;;; Each entry in the HT is a bucket list, which is an assq-type
+;;; of list, for fast searching.  Each bucket looks like:
+;;; ( (<sx> <func> <leftparenloc>)) ... [repeated], or NIL if there
+;;; are no entries.  Func is the function the form is found in, and
+;;; <leftparenloc> points to the <sx> on the didl-screen for <func>.
+
+
+;;; HT-Setup should be called when DIDL is first entered.  It initializes
+;;; the $hash-table array.
+
+(defun ht-setup (size)
+       (setq $hash-table (newarray size)))
+
+
+;;; HT-Bucket-Index returns the array slot number for a particular sx.
+
+(defun ht-bucket-index (sx)
+       (\ (abs (maknum sx)) (cadr (arraydims $hash-table))))
+
+
+;;; HT-Enter looks up an sx in the HT.  If found, it returns
+;;; which is (sx func leftparenloc), if it already existed.
+;;; If the sx is new, it enters it in the HT, and returns (sx . nil).
+
+(defun ht-enter (sx)
+       (vars (bucket-index bucket pair)
+	     (setq bucket-index (ht-bucket-index sx))
+	     (setq bucket (arrayget $hash-table bucket-index))
+	     (setq pair (assq sx bucket))
+	     (if (null pair)
+		 (prog1 (setq pair (ncons sx))
+			(push pair bucket)
+			(arraystore $hash-table bucket-index bucket))
+		 pair)))
+
+
+;;; HT-Find just looks for an sx like ht-enter, but just returns NIL
+;;; if the sx is not found, and does not add it.
+
+(defun ht-find (sx)
+       (assq sx (arrayget $hash-table (ht-bucket-index sx))))
+
+;;; Window functions for displaying parts of a screen onto the user's
+;;; terminal.
+
+;;; Window-Clear erases everything in the window.
+
+(defun window-clear ()
+       (for window-line 0 (+ $window-length $info-area-length)
+	    (cursorpos window-line 0 $window-tty)
+	    (cursorpos 'L $window-tty))
+       (cursorpos (1+ $window-length) 0 $window-tty))
+
+
+;;; Window-Display fills the window with screen starting at first-screen-line.
+
+(defun window-display (screen first-screen-line)
+       (window-display-part screen first-screen-line 1 $window-length))
+
+
+
+;;; Window-Display-Part only changes part of the window and does
+;;; not bother the rest of the window. Top-screen-line is the line
+;;; corresponding to window-line 1, not to first-window-line.
+
+(defun window-display-part (screen top-screen-line first-window-line
+				   last-window-line)
+       (do ((screen-line (+ top-screen-line first-window-line -1)
+			 (1+ screen-line))
+	    (window-line first-window-line (1+ window-line))
+	    (last-screen-line (arrayget screen 0)))
+	   ((> window-line last-window-line))
+	   (if (> screen-line last-screen-line)
+	       (window-clear-line window-line)
+	       (window-output-line (arrayget screen screen-line)
+				   window-line))))
+
+
+;;; Window-Redisplay repaints the window, putting line at the middle
+;;; of the window if reasonable.  It returns the number of the screen
+;;; line that is at the top of the window.
+
+(defun window-redisplay (screen line)
+       (cond
+	((<= line (// $window-length 2))
+	 (window-display screen 1)
+	 1)
+	(t
+	 (let ((top-line (- line (// $window-length 2))))
+	      (window-display screen top-line)
+	      top-line))))
+
+
+;;; Window-Redisplay-If-Necessary does a Window-Redisplay with the
+;;; given screen only if line is not on the current window, given that
+;;; top-line is at the top of window.  It returns the new top-line.
+
+(defun window-redisplay-if-necessary (screen top-line line)
+       (if (or (< line top-line)
+	       (> line (+ top-line $window-length -1)))
+	   (window-redisplay screen line)
+	   top-line))
+
+
+;;; Window-Output-Line does a clear-to-end-of-line on the window line,
+;;; and then puts the screen line onto it.
+
+(defun window-output-line (screen-line window-line)
+       (window-clear-line window-line)
+       (do ((char-index 1 (1+ char-index))
+	    (last-char-index (arrayget screen-line 0)))
+	   ((> char-index last-char-index))
+	   (tyo (line-char screen-line char-index) $window-tty)))
+
+;;; Window-Clear-Line goes to the beginning of a window line, and
+;;; then does a clear-to-end-of-line.
+
+(defun window-clear-line (window-line)
+       (window-set-cursor window-line 1)
+       (cursorpos 'L $window-tty))
+
+
+;;; Stuff-Line puts its exploden'd arguments into line.
+
+(defun stuff-line expr numbargs
+       (do ((arg-num 2 (1+ arg-num))
+	    (line (arg 1))
+	    (char-num 1)
+	    (chars))
+	   ((or (> char-num $screen-width) (> arg-num numbargs))
+	    (arraystore line 0 (1- char-num)))
+	   (setq chars (arg arg-num))
+	   (do ()
+	       ((or (> char-num $screen-width) (null chars)))
+	       (arraystore line char-num (car chars))
+	       (setq chars (cdr chars))
+	       (setq char-num (1+ char-num)))))
+
+
+;;; ExplodenDec does an explode with base=10. and *nopoint=t, so
+;;; numbers will come out in decimal.
+
+(defun explodendec (x)
+       (let ((base 10.) (*nopoint t))
+	    (exploden x)))
+
+
+;;; Window-Set-Status-Line does a Stuff-Line into $status-line.
+
+(defun window-set-status-line expr numbargs
+       (apply (function stuff-line)
+	      (cons $status-line
+			 (mapcar 'explodendec (listify numbargs)))))
+
+
+;;; Window-Display-Status-Line displays $status-line at the line that
+;;; is 1 greater than $window-length.  But this line is really included
+;;; in the window area.
+
+(defun window-display-status-line ()
+       (window-output-line $status-line (1+ $window-length)))
+
+
+;;; Window-Set-Cursor does a cursorpos in the window.  The window is 1-origin
+;;; indexing, and cursorpos is 0-origin.
+
+(defun window-set-cursor (line col)
+       (cursorpos (1- line) (1- col) $window-tty))
+
+
+;;; Window-Set-Cursor-With-Pos uses info about the top window line
+;;; to set the cursor to a pos.
+
+(defun window-set-cursor-with-pos (top-screen-line-on-window pos)
+       (window-set-cursor (- (1st pos) top-screen-line-on-window -1)
+			  (2nd pos)))
+
+
+;;; Window-Clear-And-Print just does a print into the window region
+;;; after clearing it.
+
+(defun window-clear-and-print (what-to-print)
+       (window-clear)
+       (window-print what-to-print)
+       (window-terpri))
+
+;;; Other window-printing functions.
+
+(defun window-print (x)
+       (print x $window-tty))
+
+
+(defun window-princ (x)
+       (princ x $window-tty))
+
+
+(defun window-prin1 (x)
+       (prin1 x $window-tty))
+
+
+(defun window-terpri ()
+       (terpri $window-tty))
+
+
+(defun window-tyo (char)
+       (tyo char $window-tty))
+
+;;; Following are various Info-Area printing functions.
+
+;;; Info-Area-Clear clears the info area, which is the two lines below
+;;; the status line.
+
+(defun info-area-clear ()
+       (for info-line 1 $info-area-length
+	    (cursorpos (+ $window-length info-line) 0 $window-tty)
+	    (cursorpos 'L $window-tty))
+       (cursorpos (1+ $window-length) 0 $window-tty))
+
+
+(defun info-area-terpri ()
+       (terpri $window-tty))
+
+
+(defun info-area-princ (x)
+       (princ x $window-tty))
+
+
+(defun info-area-print (x)
+       (print x $window-tty))
+
+
+(defun info-area-prin1 (x)
+       (prin1 x $window-tty))
+
+
+;;; These functions do various terpri's before and after printing
+;;; for convenience.
+
+(defun info-area-printc (x)
+       (info-area-terpri)
+       (princ x $window-tty))
+
+
+(defun info-area-princt (x)
+       (princ x $window-tty)
+       (info-area-terpri)))
+
+
+(defun info-area-prin1t (x)
+       (prin1 x $window-tty)
+       (info-area-terpri)))
+
+;;; Following are various Echo-Area printing functions.
+
+;;; Echo-Area-Clear clears the echo area, which also sets the cursor
+;;; to the top left of the area.
+
+(defun echo-area-clear ()
+       (cursorpos 'C $echo-area-tty))
+
+
+(defun echo-area-terpri ()
+       (terpri $echo-area-tty))
+
+
+(defun echo-area-princ (x)
+       (princ x $echo-area-tty))
+
+
+(defun echo-area-print (x)
+       (print x $echo-area-tty))
+
+
+(defun echo-area-prin1 (x)
+       (prin1 x $echo-area-tty))
+
+
+;;; These functions do various terpri's before and after printing
+;;; for convenience.
+
+(defun echo-area-printc (x)
+       (echo-area-terpri)
+       (princ x $echo-area-tty))
+
+
+(defun echo-area-princt (x)
+       (princ x $echo-area-tty)
+       (echo-area-terpri)))
+
+
+(defun echo-area-prin1t (x)
+       (prin1 x $echo-area-tty)
+       (echo-area-terpri)))
+
+
+;;; Echo-Area-Prompt-And-Read clears the echo area, then princ's all its
+;;; arguments to prompt the user.  It then does a (read) and returns its value.
+;;; If the user over-rubouts, causing an end-of-file condition on tyi,
+;;; Echo-Area-Prompt-And-Read throws back to Abort-Command.
+
+(defun echo-area-prompt-and-read numbargs
+       (echo-area-clear)
+       (for i 1 numbargs
+	    (echo-area-princ (arg i)))
+       (let ((thing-read (read $unique-symbol))) ;(read) returns $unique-symbol
+	    (and (eq thing-read $unique-symbol)	 ; if user over-rubouts
+		 (throw 'abort-command abort-command))
+	    (echo-area-terpri)
+	    thing-read))
+
+
+;;; Echo-Area-Prompt-And-Read-With-Default is like Echo-Area-Prompt-And-Read,
+;;; but (arg 1) is a default to use if the user just types space.
+
+(defun echo-area-prompt-and-read-with-default numbargs
+       (echo-area-clear)
+       (for i 2 numbargs
+	    (echo-area-princ (arg i)))
+       (caseq (tyipeek)
+	      (40		; If just a space is typed, return the default.
+	       (arg 1))
+	      (177
+	       (throw 'abort-command abort-command))	; Rubout will abort it.
+	      (t
+	       (let ((thing-read (read $unique-symbol)))
+		    			; (read) returns $unique-symbol
+					;  if user over-rubouts.
+		    (and (eq thing-read $unique-symbol)
+			 (throw 'abort-command abort-command))
+		    (echo-area-terpri)
+		    thing-read))))
+
+
+
+;;; Open-TTYS sets up $window-tty and $echo-area-tty, making $window-tty
+;;; the normal full-screen tty, and opens a new tty called $echo-area-tty.
+
+(defun open-ttys ()
+       (setq $echo-area-tty (open '((tty)) '(tty out echo)))
+       (setq $window-tty tyo)
+       (endpagefn $window-tty (function didl-endpagefn))
+       (endpagefn $echo-area-tty (function didl-endpagefn)))
+
+
+;;; Split-Screen does a SCML on $echo-area-tty.
+
+(defun split-screen ()
+       (syscall 0 'scml $echo-area-tty $echo-area-length)
+       (sstatus ttycons $echo-area-tty tyi)
+       (setq tyo $echo-area-tty)
+       (setq $is-screen-split? t))
+
+
+;;; Unsplit-screen undoes the SCML.
+
+(defun unsplit-screen numbargs
+       (and (= numbargs 2)
+	    (tyi))
+       (syscall 0 'scml $echo-area-tty 0)
+       (setq tyo $window-tty)
+       (sstatus ttycons tyo tyi)
+       (setq $is-screen-split? nil))
+
+
+;;; DIDL-Endpagefn is a simple-minded one, unlike the +INTERNAL-TTY-ENDPAGEFN,
+;;; which requires the channel it is on to be TTYCONS'd with TYI.
+
+(defun didl-endpagefn (output-tty)
+       (nointerrupt nil)	; Make sure the guy can ^G (etc..)
+       (princ '|##More##| output-tty)
+       (tyi)			; Eat a character
+       (cursorpos 'Z output-tty)	; Clear the ##More##
+       (cursorpos 'L output-tty)
+       (cursorpos 'TOP output-tty))
+
+
diff --git a/src/libdoc/dirsiz.gsb2 b/src/libdoc/dirsiz.gsb2
new file mode 100644
index 00000000..6387ddd6
--- /dev/null
+++ b/src/libdoc/dirsiz.gsb2
@@ -0,0 +1,44 @@
+;	Wednesday  Feb 11,1981  1:46  NM+7D.0H.24M.10S.  -*- .Fasl -*-
+
+.fasl
+
+if1,[
+.insrt sys:.fasl defs
+.insrt syseng;fsdefs
+]
+
+verprt DIRSIZE
+
+; (DIRECTORY-SIZE directory-name) gives you the size of that directory.
+; No overhead from buffering arrays, file objects, consing up lists
+; and symbols from calling DIRECTORY, etc.  Just opens the image dir,
+; and gets the number-of-blocks allocated number.
+
+.entry DIRECTORY-SIZE SUBR 002
+	push p,cfix1
+	pushj p,sixmak
+	movei f,1(fxp)
+	jsp t,0push-<udblks+1>
+	hrli f,<-<udblks+1>>
+	push fxp,inhibit
+	setom inhibit
+	.call [setz ? sixbit |OPEN| ? movei 0 ? movsi .bii
+		    move [sixbit |DSK|]
+		    move [sixbit |.FILE.|]
+		    move [sixbit |(DIR)|]
+		    setz tt]
+	  jrst oh.foo
+	.iot 0,f
+	.close 0,
+	pushj p,intrel
+	pop fxp,tt
+	hrrzs tt
+	sub fxp,[udblks,,udblks]
+	popj p,
+
+oh.foo:	movni tt,1
+	pushj p,intrel
+	sub fxp,[<udblks+1>,,<udblks+1>]
+	popj p,
+
+fasend
diff --git a/src/libdoc/hash.gjc1 b/src/libdoc/hash.gjc1
new file mode 100644
index 00000000..14993645
--- /dev/null
+++ b/src/libdoc/hash.gjc1
@@ -0,0 +1,64 @@
+;;-*-LISP-*-
+;; LISPM compatible functions for hash-tables on EQ and EQUAL.
+;; Hashing off the address using MAKNUM is easy in Maclisp
+;; since the garbage collector is not relocating.
+
+(herald hash 1)
+
+(eval-when (compile)
+  (setq defmacro-for-compiling nil))
+
+(defmacro make-hash-table-internal (dim factor)
+  `(let ((hash-table (*array nil t (+ ,dim 3))))
+     (setf (hash-ind) gethash)
+     (setf (hash-dim) ,dim)
+     (setf (hash-factor) ,factor)
+     hash-table))
+
+(defmacro hash-ref (index &optional (hash-table 'hash-table))
+  `(arraycall t ,hash-table (+ ,index 3)))
+(defmacro hash-ind (&optional (hash-table 'hash-table))
+  `(arraycall t ,hash-table 0))
+(defmacro hash-dim (&optional (hash-table 'hash-table))
+  `(arraycall t ,hash-table 1))
+(defmacro hash-factor (&optional (hash-table 'hash-table))
+  `(arraycall t ,hash-table 2))
+
+(defvar gethash (list 'gethash) "Unique object for hash-table-verification")
+
+(defun hash-table-identity (hash-table)
+  (if (and (eq (typep hash-table) 'array)
+	   (eq (hash-ind) gethash))
+      hash-table
+      (hash-table-identity (error "not a hash table" hash-table 'wrng-type-arg))))
+
+(defun gethash (hash-table key)
+  (if *rset (setq hash-table (hash-table-identity hash-table)))
+  (do ((alist (hash-ref (\ (maknum key) (hash-dim)))
+	      (cdr alist)))
+      ((null alist) (values nil nil))
+    (if (eq key (caar alist))
+	(return (values (cdar alist) t)))))
+
+(defun puthash (key value hash-table)
+  (if *rset (setq hash-table (hash-table-identity hash-table)))
+  (do ((alist (hash-ref (\ (maknum key) (hash-dim)))
+	      (cdr alist)))
+      ((null alist)
+       (setf (hash-ref (\ (maknum key) (hash-dim)))
+	     (list (cons key value))))
+    (if (eq key (caar alist))
+	(return (setf (cdar alist) value))))
+  value)
+
+(DEFUN MAPHASH (FUNCTION HASH-TABLE)
+    (if *rset (setq hash-table (hash-table-identity hash-table)))
+    (DO ((J 0 (1+ J))
+	 (N (HASH-DIM)))
+	((= J N))
+      (DO ((ALIST (HASH-REF J) (CDR ALIST)))
+	  ((NULL ALIST))
+	(FUNCALL FUNCTION (CDAR ALIST)))))
+
+(defun make-hash-table () ; for now this is all I need
+  (make-hash-table-internal 100 1.3))
diff --git a/src/libdoc/iter.rms19 b/src/libdoc/iter.rms19
new file mode 100644
index 00000000..e6055c38
--- /dev/null
+++ b/src/libdoc/iter.rms19
@@ -0,0 +1,556 @@
+;-*-LISP-*-
+
+;ITER is a generalized iteration construct based on the use of
+;input and output streams.  For efficiency, input and output from
+;ITER streams is expanded using macros.  Several types of stream
+;are predefined, and the user can easily define new types.
+
+;Here is an example of an ITER:
+;(ITER ((LIST-IN PROP PROPS) (LIST-OUT VAL VALS) (LOCAL X))
+;      VALS
+;      (SETQ X (GET FOO (FETCHR PROP)))
+;      (AND X (SEND VAL X)))
+;It takes all the indicators in PROPS and returns a list
+;of all the non-null properties which the symbol in FOO
+;has on any of those indicators.
+
+;The first thing in an ITER is a list of stream definitions.
+;   Each stream definition starts with a type, followed by the stream name,
+;   followed by optional extra info for that type of stream.
+;The second thing in an ITER is the thing it should normally return.
+;   It can be any form, which will be evaluated just before returning it.
+;   "Normally" means when exited by a failing FETCHR.
+;   You can also do a RETURN out of the ITER, returning whatever you like.
+;   You must not use tags or go's, however.
+;Then comes the body, which is evaluated over and over.
+;In the body, (SEND stream value) gives a value to an output stream.
+;   The value returned by SEND is unpredictable.  The value of
+;   the stream name as a variable is not changed;  for an output-only
+;   stream, that variable may not even be bound.
+;(FETCH stream) gets the next value from an input stream.
+;   It returns T if there was another value, NIL if it was empty.
+;   The value itself goes in a local variable with the same name as the stream.
+;(FETCHR stream) fetches the next value from the stream, returning from the ITER
+;   if the stream is empty, returning the new value if there is one.
+;   The value also goes into the local variable as with FETCH.
+;   Since FETCHRs do RETURNS implicitly, you must not use FETCHR inside
+;   any PROGs or DOs within the body of the ITER.
+;(FETCHR stream1 stream2 ... streamn) does a FETCHR on each stream
+;    and returns the new value got from the last one.
+;(FETCHF stream) is like (FETCHR stream) except that the stream-name
+;   variable is NOT set.  The next object is just returned by the FETCHF.
+;   Use FETCHF instead of FETCHR in simple cases, for extra efficiency.
+;   If the particular stream type does not supply a definition for FETCHF,
+;   an ordinary FETCHR is done, so you will get the right behavior.
+
+
+; The predefined types of streams are:
+;(LOCAL var var var...)
+;   simply causes the variables to be bound by the ITER.
+;   They can't be fetched from or sent to.
+;   Initializations are possible, as in (LOCAL (X 1) (Y 'FOO)).
+;(MAPC name init)
+;   fetches the elements of <init> one by one.
+;   There is no way to refer to the list of remaining values.
+;   For that, use STACK or STACK-GLOBAL.
+;   MAPC generates very good code when used with ITER-FETCHR.
+;(LIST-OUT name)
+;   accumulates a list in a fifo manner, optimally.  To access the value,
+;   you must do (ITER-LIST name), and you can only do it once.
+;   On the PDP-10, this uses NREVERSE.  On the Lisp machine, it uses locatives.
+;   On other machines, it may work in yet other ways.
+;(STACK name listname [init])
+;   <listname> is a variable (bound in the ITER) which holds a list initialized
+;   to the same variable's outer binding, or to <init>, if <init> is given.
+;   Fetching takes the next element from <listname> and puts it in <name>.
+;   Sending conses the sent object onto the list.
+;   STACK streams can be used either as lifo lists of objects to be processed
+;   or just for processing a list's elements in order a la MAPCAR.
+;(STACK-GLOBAL name listname)
+;   works like STACK except that <listname> is not bound by the ITER.
+;   It can be used for taking things off a global list of things to do.
+;(LIST-OUT-ORDERED name listname)
+;   is used for building up a list that is always in correct order.
+;   Sending to it NCONCs onto the end of <listname>.
+;(STEP name to [from] [by])
+;   starts <name> out as <from> (or zero) after the first fetch,
+;   and each successive fetch increments <name> by <by> (or 1).
+;   The stream is empty if <name> comes to equal <to>.
+;   Thus, <to> is an exclusive bound, never returned as a value by the stream.
+;(STEP-GLOBAL ...)
+;   is like STEP except that the stepped variable is free, rather
+;   than bound by the ITER.
+;(ESCAPE name fetchfn sendfn init)
+;   makes a stream named <name> initialized to <init>
+;   that fetches by calling <fetchfn> and sends by calling <sendfn>.
+;   The fetch function is passed the stream definition (the list (ESCAPE ...))
+;   as its argument.  The send function is passed that and the value to send.
+;   If the fetch or send function is NIL, that operation is not allowed.
+;   Internal lambdas work efficiently as the fetch and step functions.
+
+;ITER-FETCHR is like ITER except that every input stream is FETCHRed
+;automatically at the start of each cycle.  An input stream is one
+;whose definition notices the auto-fetch-flag argument it is passed
+;and generates an automatic fetchr.  The predefined stream types
+;MAPC, STACK, STACK-GLOBAL, STEP, and STEP-GLOBAL will automatically fetchr.
+;The others, LIST-OUT, LOCAL and ESCAPE, will not be affected by this.
+;Automatic FETCHRs generate good code.
+;ITER-FETCHR is especially efficient with MAPC streams.
+
+;In order to use ITER, you need a DISPLACE function.
+;Since people have different favorite versions of it, none is included.
+;Since ITER is implemented as a macro, if you compile code that uses ITER
+;you must load ITER FASL into the compiler.
+
+;Macros, etc., needed by the compilation of ITER itself.
+
+(DECLARE 
+ (COND ((AND (NOT (= 1_24. 0))		;IN MACLISP
+	     (OR (NOT (BOUNDP 'COMPILING-FOR-LISPM))
+		 (NULL COMPILING-FOR-LISPM)))
+
+ ;;;IF NOT IN LISP MACHINE AND NOT COMPILING FOR IT IN QCMP,
+ ;;;WE MUST SET UP SOME OF THE LISP MACHINE ENVIRONMENT THAT WE USE.
+
+  (DEFUN IF-FOR-LISPM MACRO (FORM) NIL)
+  (DEFUN IF-FOR-MACLISP MACRO (FORM) (CONS 'PROGN (CONS ''COMPILE (CDR FORM))))
+
+ ;;;SIMILAR UNQUOTE MACRO TO WHAT IS IN LISP MACHINE.
+ ;;;NOTE:  COMMA IS DEFINED ALL THE TIME, NOT JUST IN BACKQUOTE.
+  (SETQ **BACKQUOTE** NIL)
+
+  (SETSYNTAX '/` 'MACRO '(LAMBDA ()
+     (MACLISP-BACK-QUOTIFY ((LAMBDA (**BACKQUOTE**) (READ))
+			    T))))
+
+  (SETSYNTAX '/, 'MACRO '(LAMBDA ()
+    (COND ((NULL **BACKQUOTE**)
+	   (ERROR '|COMMA NOT INSIDE BACKQUOTE| NIL 'FAIL-ACT))
+	  ((EQ (TYIPEEK) 100)	;CAN'T USE ## SINCE NOT DEFINED YET	;WAS IT A ",@"?
+	   (TYI)
+	   (CONS '/,/@ (READ)))
+	  (T
+	   (CONS '/, (READ))))))
+
+  (DEFUN MACLISP-BACK-QUOTIFY (X)
+   ((LAMBDA (A D)
+     (COND ((ATOM X) (LIST 'QUOTE X))
+	   ((EQ (CAR X) '/,)
+	    (CDR X))
+	   ((OR (ATOM (CAR X))
+		(NOT (EQ (CAAR X) '/,/@)))
+	    ;(LIST 'CONS (MACLISP-BACK-QUOTIFY (CAR X))
+	    ;	        (MACLISP-BACK-QUOTIFY (CDR X)))
+	    (SETQ A (MACLISP-BACK-QUOTIFY (CAR X)) D (MACLISP-BACK-QUOTIFY (CDR X)))
+	    (COND ((AND (NOT (ATOM A))
+			(NOT (ATOM D))
+			(EQ (CAR A) 'QUOTE)
+			(EQ (CAR D) 'QUOTE))
+		   (LIST 'QUOTE (CONS (CADR A) (CADR D))))
+		  (T (LIST 'CONS A D))))
+	   (T
+	    (LIST 'APPEND (CDAR X)
+			  (MACLISP-BACK-QUOTIFY (CDR X))))))
+    NIL NIL)))))
+
+;This is the main entry point of this file.
+
+(defun iter macro (form)
+    (displace form (iter-expand (cadr form) (caddr form) (cdddr form) nil)))
+
+(defun iter-fetchr macro (form)
+    (displace form (iter-expand (cadr form) (caddr form) (cdddr form) t)))
+
+(defun iter-test (form)
+    (iter-expand (cadr form) (caddr form) (cdddr form) nil))
+
+
+;For each stream, we call the ITER-STREAM-DEFINER property of the stream type.
+;The arguments it is given are the stream definition,
+; and whether to do an automatic fetchr at the start of each cycle
+; (output-only streams ignore this argument).
+;It should return a list containing three things:
+; 1st, an updated stream definition (defaults filled in, etc.).
+; 2nd, a list of local variable binding specs for a DO  (for example, ((X) (Y FOO) (Z)) ).
+; 3rd, a list of forms to be done at the start of each ITER cycle.
+; 4th, a list of end-tests.  All end-tests are or'ed together.
+;  end-tests need only be supplied if an automatic fetchr is being done.
+; 5th, a list of forms to be used to init global variables before starting the iteration.
+; 6th, a list of variables to be bound each time through the iter.
+; 7th, a list of the things (forms) to bind them to.
+
+(defun iter-expand (stream-list value-form body auto-fetch-flag)
+    (prog (stream-defs local-vars setups each-cycle end-tests tem inner-vars inner-var-values)
+	  (do ((streams stream-list (cdr streams)))
+	      ((null streams))
+	      (setq tem (funcall (get (caar streams) 'iter-stream-definer)
+				 (car streams)
+				 auto-fetch-flag))
+	      (setq stream-defs (cons (cons (cadar streams) (car tem))
+				      stream-defs))
+	      (setq local-vars (nconc (cadr tem) local-vars))
+	      (setq each-cycle (nconc (caddr tem) each-cycle))
+	      (setq end-tests (nconc (cadddr tem) end-tests))
+	      (setq setups (nconc (car (cddddr tem)) setups))
+	      (setq inner-vars (nconc (cadr (cddddr tem)) inner-vars))
+	      (setq inner-var-values (nconc (caddr (cddddr tem)) inner-var-values)))
+	  ;; Turn end-tests into a form which checks them all.
+	  (cond ((null end-tests))
+		((cdr end-tests)
+		 (setq end-tests (cons 'or end-tests)))
+		(t (setq end-tests (car end-tests))))
+	  (return `(compiler-bind ((iter-streams ,@stream-defs)
+				   (iter-value (iter-value . ,value-form)))
+		      (progn ,@setups
+			;; We use a DO since that way MACLISP allows initializations.
+		        (do ,local-vars
+			    (,end-tests
+			     . ,(and end-tests (list value-form)))
+			    ((lambda ,inner-vars
+				,@each-cycle
+				,@body)
+			     . ,inner-var-values)
+			    ))))))
+
+;Expand (SEND stream arg).  Look up the stream and pass the stream's definition
+;and the form for arg to the ITER-SEND-EXPANDER function for this type of stream.
+(defun send macro (form)
+    (prog (stream newval strdef sendfn)
+	  (setq stream (cadr form) newval (caddr form))
+	  (setq strdef (compiler-bindings-search '|Undefined stream name| 'iter-streams stream))
+	  (setq sendfn (get (car strdef) 'iter-send-expander))
+	  (or sendfn (error stream '|Stream can't fetch|))
+	  (return (displace form (funcall sendfn strdef newval)))))
+
+;Expand (FETCH stream).  Look up the stream and pass the stream's definition
+;to the ITER-FETCH-EXPANDER function for this type of stream.
+(defun fetch macro (form)
+    (prog (stream strdef sendfn)
+	  (setq stream (cadr form))
+	  (setq strdef (compiler-bindings-search '|Undefined stream name| 'iter-streams stream))
+	  (setq fetchfn (get (car strdef) 'iter-fetch-expander))
+	  (or fetchfn (error stream '|Stream can't send|))
+	  (return (displace form (funcall fetchfn strdef)))))
+
+;Expand (FETCHF stream).  Look up the stream and pass the stream's definition
+;to the ITER-FETCHF-EXPANDER function for this type of stream.  If there
+;is none, tret this FETCHF as a FETCHR.
+(defun fetchf macro (form)
+    (prog (stream strdef sendfn value-form)
+	  (setq value-form (compiler-bindings-search '|ITER internal lossage|
+						     'iter-value 'iter-value))
+	  (setq stream (cadr form))
+	  (setq strdef (compiler-bindings-search '|Undefined stream name| 'iter-streams stream))
+	  (setq fetchfn (get (car strdef) 'iter-fetchf-expander))
+	  (return (displace form
+			    (cond (fetchfn (funcall fetchfn strdef value-form))
+				  (t `(progn (or (fetch ,stream) (return ,value-form))
+					     ,stream)))))))
+
+(defun fetchr macro (streams)
+    (displace streams
+       (prog (return-form)
+	     (setq return-form (compiler-bindings-search '|ITER internal lossage|
+							 'iter-value 'iter-value))
+	     (return
+	      `(progn ,@(mapcar (function (lambda (stream)
+				    `(or (fetch ,stream) (return ,return-form))))
+				(cdr streams))
+		      ,(car (last streams)))))))
+
+(declare (special compiler-binding-list))
+(setq compiler-binding-list nil)
+
+;The compiler-binding-list is a list of any number of entries.
+;The car of an entry is its entry-type.  The cdr is an alist of bindings,
+;each binding being (object . value).
+
+;(COMPILER-BINDINGS-SEARCH '|No BAR for this| 'BAR 'FOO)
+;searches for compiler binding entries of type BAR
+;and searches each one for a binding for FOO.
+;If one is found, the value associated with FOO in the binding is returned.
+;Otherwise, an error with message "No BAR for this" is caused.
+;NIL as the error message means return NIL instead of erring.
+
+(defun compiler-bindings-search (errmsg entry-type object)
+    (do ((entries compiler-binding-list (cdr entries))
+	 (val))
+	((null entries) (and errmsg (error object errmsg)))
+	(and (eq entry-type (caar entries))
+	     (setq val (assoc object (cdar entries)))
+	     (return (cdr val)))))
+
+;(COMPILER-BIND list-of-bindings form form...)
+;evaluates the forms with list of bindings appended to the
+;COMPILER-BINDING-LIST to be visible to COMPILER-BINDINGS-SEARCH.
+;It is a macro which sets COMPILER-BINDING-LIST to the new value
+;but sticks onto the end of the forms to be evaluated
+;a call to the macro COMPILER-UNBIND, which resets COMPILER-BINDING-LIST
+;when it is expanded (AFTER the body is expanded).
+
+(defun compiler-bind macro (form)
+    (prog (tem)
+	  (setq tem compiler-binding-list)
+	  (setq compiler-binding-list (append (cadr form) compiler-binding-list))
+	  (return `(prog2 nil (progn ,@(cddr form))
+			  (compiler-unbind ,tem)))))
+
+(defun compiler-unbind macro (form)
+    (setq compiler-binding-list (cadr form))
+    nil)
+
+;Definition of STACK type streams.
+;(STACK topvar restvar init) defines a stream named <topvar>
+;which is a stack.  <topvar> is the element at the top.
+;<restvar> is a list of the rest of the elements.
+;Fetching loads <topvar> from <restvar>, which is popped.
+;Sending just conses onto <restvar>.  This is right for
+;using a STACK as a stack of things to process.
+;It is also right for just building up a list in reverse order (to nreverse, maybe).
+;<init> is used to initialize <restvar>.  If left out, the external
+;value of <restvar> is used;  however, <restvar> is always rebound.
+
+(defprop stack iter-stack-definer iter-stream-definer)
+
+(defun iter-stack-definer (stream-def auto-fetch)
+    (do ((elt (cadr stream-def))
+	 (list (caddr stream-def))
+	 (init (or (cadddr stream-def) (caddr stream-def))))
+	(t
+	 `(,stream-def
+	   ((,elt)
+	    (,list
+	     ,init))
+	   ,(and auto-fetch `((fetchr ,elt)))))))
+
+(defprop stack iter-stack-fetch iter-fetch-expander)
+
+(defun iter-stack-fetch (stream-def)
+    `(cond (,(caddr stream-def)
+	    (setq ,(cadr stream-def) (car ,(caddr stream-def)))
+	    (setq ,(caddr stream-def) (cdr ,(caddr stream-def)))
+	    T)))
+
+(defprop stack iter-stack-fetchf iter-fetchf-expander)
+
+(defun iter-stack-fetchf (stream-def value-form)
+    `(cond (,(caddr stream-def)
+	    (prog2 nil (car ,(caddr stream-def))
+		   (setq ,(caddr stream-def) (cdr ,(caddr stream-def)))))
+	   (t (return ,value-form))))
+
+(defprop stack iter-stack-send iter-send-expander)
+
+(defun iter-stack-send (stream-def arg-form)
+    `(setq ,(caddr stream-def) (cons ,arg-form ,(caddr stream-def))))
+
+;Definition of STACK-GLOBAL type.  Like STACK except that the stack-remainder
+;variable is not bound by the ITER.  The top-of-stack variable (the stream name)
+;is still bound.
+
+(defprop stack-global iter-stack-fetch iter-fetch-expander)
+(defprop stack-global iter-stack-fetchf iter-fetchf-expander)
+(defprop stack-global iter-stack-send iter-send-expander)
+
+(defprop stack-global iter-stack-global-definer iter-stream-definer)
+
+(defun iter-stack-global-definer (stream-def auto-fetch)
+    (or (cddr stream-def)
+	(error '|STACK-GLOBAL: No name for the stack itself| stream-def))
+    `(,stream-def
+      ((,(cadr stream-def)))
+      ,(and auto-fetch `((fetchr ,(cadr stream-def))))
+      nil
+      ,(and (cadddr stream-def)
+	    `((setq ,(caddr stream-def) ,(cadddr stream-def))))))
+
+
+;Definition of MAPC stream type.
+;Although the user supplies (MAPC name init),
+;the stream-def that we supply for compiler-binding says
+;(MAPC name gensym init).
+;In an ITER (as opposed to an ITER-FETCHR), MAPC is treated as a STACK,
+;since that is the most efficient way to do it, then.
+
+(defprop mapc iter-mapc-definer iter-stream-definer)
+
+(defun iter-mapc-definer (stream-def auto-fetch)
+    (do ((name (cadr stream-def))
+	 (init (caddr stream-def))
+	 (tem (intern (gensym))))
+	(t
+	 (cond (auto-fetch
+		`((mapc ,name ,tem ,init)
+		  ((,tem ,init (cdr ,tem)))
+		  nil
+		  ((null ,tem))
+		  nil
+		  (,name)				;Bind this each time around,
+		  ((car ,tem))))			;to this.
+	       (t 
+		`((stack ,name ,tem ,init)
+		  ((,name)
+		   (,tem ,init))))))))
+
+(defprop mapc iter-mapc-fetch iter-fetch-expander)
+
+(defun iter-mapc-fetch (stream-def)
+    `(progn (setq ,(caddr stream-def) (cdr ,(caddr stream-def)))
+	    (setq ,(cadr stream-def) (car ,(caddr stream-def)))
+	    ,(caddr stream-def)))
+
+(defprop mapc iter-mapc-fetchf iter-fetchf-expander)
+
+(defun iter-mapc-fetchf (stream-def value-form)
+    (do ((list (caddr stream-def))
+	 (name (cadr stream-def)))
+	(t `(car (or (setq ,list (cdr ,list)) (return ,value-form))))))
+
+;Definition of LIST-OUT-ORDERED stream type.
+;(LIST-OUT-ORDERED X <listvar>) defines a stream which accumulates a list in forward order.
+;<listvar> contains the list so far.  X is not defined as a variable.
+
+(defprop list-out-ordered iter-list-out-ordered-definer iter-stream-definer)
+
+(defun iter-list-out-ordered-definer (stream-def auto-fetch)
+    `(,stream-def
+      ((,(caddr stream-def)
+	,(cadddr stream-def)))))
+
+(defprop list-out-ordered iter-list-out-ordered-send iter-send-expander)
+
+(defun iter-list-out-ordered-send (stream-def arg-form)
+    `(setq ,(caddr stream-def) (nconc ,(caddr stream-def) (ncons ,arg-form))))
+
+
+;Definition of LIST-OUT stream type.
+;(LIST-OUT X) defines a stream named X which accumulates a list somehow.
+;Then say (ITER-LIST X) as the "value" of the ITER and the accumulated
+;list will be returned by the ITER.  There is no other way to use the list.
+;This makes it possible to optimize everything as much as possible.
+
+(defprop list-out iter-list-out-definer iter-stream-definer)
+
+(defun iter-list-out-definer (stream-def auto-fetch)
+    (do ((tem (intern (gensym))))
+	(t 
+	 (or (if-for-maclisp
+	      `((list-out ,(cadr stream-def) ,tem)
+		((,tem))))
+	     (if-for-lispm
+	      `((list-out ,(cadr stream-def) ,tem)
+		((,tem)
+		 (,(cadr stream-def)
+		  (value-cell-location ',tem)))))))))
+
+(if-for-maclisp
+  (defprop list-out iter-stack-send iter-send-expander))
+
+(if-for-lispm
+  (defprop list-out iter-list-out-send iter-send-expander)
+
+(defun iter-list-out-send (stream-def arg-form)
+    `(progn (rplacd ,(cadr stream-def) (ncons ,arg-form))
+	    (setq ,(cadr stream-def) (cdr ,(cadr stream-def))))))
+
+(if-for-maclisp
+  (defun iter-list macro (form)
+      (prog (stream strdef)
+	  (setq stream (cadr form))
+	  (setq strdef (compiler-bindings-search '|Undefined stream name| 'iter-streams stream))
+	  (return `(nreverse ,(caddr strdef))))))
+
+(if-for-lispm
+(defun iter-list macro (form)
+    (prog (stream strdef)
+	(setq stream (cadr form))
+        (setq strdef (compiler-bindings-search '|Undefined stream name| 'iter-streams stream))
+	(return (caddr strdef)))))
+
+;Definition of LOCAL stream type.
+;(LOCAL X Y (FOO 1)) just binds X and Y to NIL and FOO to 1.
+
+(defprop local iter-local-definer iter-stream-definer)
+
+(defun iter-local-definer (stream-def auto-fetch)
+    `(nil
+      ,(mapcar (function (lambda (var)
+		   (cond ((atom var) (ncons var))
+			 (t var))))
+	       (cdr stream-def))))
+
+
+;Definition of STEP stream type.
+;(STEP X to from by) steps X starting with <from> by <by> stopping before <to>.
+;If <by> is left out, it is 1.  If <from> is left out, it is 0.
+;<to>, <from> and <by> are re-evaluated each time they are used.
+;When the stream is exhausted, it steps anyway, but claims to be empty.
+;If <to> is left out or is NIL, the stream is inexhaustible.
+
+(defprop step iter-step-definer iter-stream-definer)
+
+(defun iter-step-definer (stream-def auto-fetch)
+    (do ((from (or (cadddr stream-def) 0))
+         (by (or (cadddr (cdr stream-def)) 1)))
+	(T
+	 (cond (auto-fetch
+		`((STEP ,(cadr stream-def) ,(caddr stream-def) ,from ,by)
+		  ((,(cadr stream-def) ,from (+ ,(cadr stream-def) ,by)))
+		  nil
+		  ((not (< ,(cadr stream-def) ,(caddr stream-def))))))
+	       (t
+		`((STEP ,(cadr stream-def) ,(caddr stream-def) ,from ,by)
+		  ((,(cadr stream-def) (- ,from ,by)))))))))
+
+(defprop step iter-step-fetch iter-fetch-expander)
+
+(defun iter-step-fetch (stream-def)
+    (cond ((caddr stream-def)				;If stream has a <to>, check it.
+	   `(< (setq ,(cadr stream-def) (+ ,(cadr stream-def) ,(cadddr (cdr stream-def))))
+	       ,(caddr stream-def)))
+	  (t `(progn (setq ,(cadr stream-def)
+			   (+ ,(cadr stream-def) ,(cadddr (cdr stream-def))))
+		     T))))
+
+;Definition of STEP-GLOBAL stream type.
+;It is just like STEP except that the iteration variable is not bound.
+
+(defprop step-global iter-step-global-definer iter-stream-definer)
+
+(defprop step-global iter-step-fetch iter-fetch-expander)
+
+(defun iter-step-global-definer (stream-def auto-fetch)
+    (do ((from (or (cadddr stream-def) 0))
+	 (by (or (cadddr (cdr stream-def)) 1)))
+	(T `((STEP ,(cadr stream-def) ,(caddr stream-def) ,from ,by)
+	     nil					;No local variables.
+	     ,(and auto-fetch `((fetchr ,(cadr stream-def))))
+	     nil
+	     ((setq ,(cadr stream-def)
+		    (- ,from ,by)))))))			;Instead, SETQ the var to init it.
+
+;Definition of ESCAPE stream type.
+;(ESCAPE name fetchfn sendfn init) makes a stream named <name> initialized to <init>
+;that fetches by calling <fetchfn> and sends by calling <sendfn>.
+;The fetch function is passed the stream definition (the list (ESCAPE ...))
+;as its argument.  The send function is passed that and the value to send.
+;If the fetch or send function is NIL, that direction is not allowed.
+;Internal lambdas work efficiently as the fetch and step functions.
+
+(defprop escape iter-escape-definer iter-stream-definer)
+
+(defun iter-escape-definer (stream-def auto-fetch)
+    `(,stream-def
+      ((,(cadr stream-def) ,(car (cddddr stream-def))))))
+
+(defprop escape iter-escape-fetch iter-fetch-expander)
+
+(defun iter-escape-fetch (stream-def)
+    (or (caddr stream-def) (error '|Stream can't fetch| stream-def))
+    `(,(caddr stream-def) ',stream-def))
+
+(defprop escape iter-escape-send iter-send-expander)
+
+(defun iter-escape-send (stream-def arg-form)
+    (or (cadddr stream-def) (error '|Stream can't send| stream-def))
+    `(,(cadddr stream-def) ',stream-def ,arg-form))
diff --git a/src/libdoc/ledit*.rich17 b/src/libdoc/ledit*.rich17
new file mode 100644
index 00000000..a0cb4db7
--- /dev/null
+++ b/src/libdoc/ledit*.rich17
@@ -0,0 +1,273 @@
+(comment LISP-TECO EDITOR INTERFACE)			; -*-LISP-*-
+
+(defun LET macro (s)
+       (cons (cons 'lambda
+		   (cons (mapcar 'car (cadr s))
+			 (cddr s)))
+	     (mapcar 'cadr (cadr s))))
+
+(declare (special ledit-jname				;atomic name of emacs job 
+		  ledit-loadfile			;namestring of binary file for editor
+		  ledit-library				;namestring of teco macro library
+		  ledit-tags				;namestring of tags file
+		  ledit-tags-find-file			;0 or 1 controls setting of qreg in 
+							; teco whether to use Find File
+		  ledit-deletef				;switch, if T delete file from teco
+							; after reading
+		  ledit-pre-teco-func			;called with list of arguments given
+							; to ledit
+		  ledit-post-teco-func			;called with namestring of file
+							; returned from teco
+		  ledit-pre-eval-func			;called with form to be eval'ed,
+							; returns form to be eval'ed instead
+		  ledit-eof				;gensym once to save time
+		  ledit-jcl				;pre-exploded strings to save time
+		  ledit-valret				; "
+		  ledit-proceed				; "
+		  ledit-jname-altj			; "
+		  ledit-lisp-jname			; "
+		  ledit-find-tag			; "
+		  ledit-find-file			; "
+		  ledit-lisp-mode			; "
+		  defun					;enables expr-hash hack
+		  tty-return))				;system variable
+
+;; default values for global variables
+
+(or (boundp 'ledit-jname)(setq ledit-jname 'LEDIT))
+(or (boundp 'ledit-loadfile)(setq ledit-loadfile '|SYS2;TS EMACS|))
+(or (boundp 'ledit-library)(setq ledit-library '|EMACS;LEDIT*|))	
+(or (boundp 'ledit-tags)(setq ledit-tags nil))
+(or (boundp 'ledit-tags-find-file)(setq ledit-tags-find-file 1))
+(or (boundp 'ledit-deletef)(setq ledit-deletef nil))	;for development
+(or (boundp 'ledit-pre-teco-func)(setq ledit-pre-teco-func nil))
+(or (boundp 'ledit-post-teco-func)(setq ledit-post-teco-func nil))
+(or (boundp 'ledit-pre-eval-func)(setq ledit-pre-eval-func nil))
+(or pure (setq pure 3))
+
+(setq ledit-eof (gensym))
+(setq ledit-jname-altj nil)
+(setq ledit-valret nil)
+(setq ledit-jcl (exploden '|:JCL |))
+(setq ledit-find-tag (exploden '|WMMFIND TAG|))
+(setq ledit-find-file (exploden '|WMMFIND FILE|))
+(setq ledit-lisp-jname (exploden '|W:ILEDIT LISP JNAME|))
+(setq ledit-lisp-mode (exploden '|1MMLISP MODEW|))
+(setq tty-return 'ledit-tty-return))
+
+(setq ledit-proceed (exploden '|
+/
+..UPI0// /
+:IF E Q&<%PIBRK+%PIVAL>/
+(:ddtsym tygtyp///
+:if n q&10000/
+(: Teco Improperly Exited, Use ^Z (NOT CALL!)/
+)/
+:else/
+(: Teco Improperly Exited, Use ^X^C (NOT ^Z !)/
+)/
+:SLEEP 30./
+P/
+:INPOP/
+)/
+2// /
+Q+8//-1 /
+.-1G|))
+    
+(comment USER FUNCTIONS)
+
+(defun FLOAD fexpr (filespec)
+       ;; given filespec of FASL file, first FASLOAD it in
+       ;; then compare creation dates with corresponding EXPR (assuming
+       ;; second file name >) and if it is more recent,
+       ;; LOAD it in with DEFUN=T and snap uuolinks
+       ;; returns name of last file loaded
+       (let ((faslfile (mergef (mergef filespec (cons '* 'fasl)) defaultf))
+	     (exprfile (probef (mergef (mergef (cons '* '>) filespec) defaultf))))
+	    (cond ((probef faslfile)
+		   (load faslfile)
+		   (cond ((ledit-olderp faslfile exprfile)
+			  (let ((defun t))(load exprfile))
+			  (sstatus uuolinks)
+			  (and (< (cadr (status uuolinks)) 10.)
+			       (princ '|;Warning - down to less than 10 uuolinks.|))
+			  exprfile)
+			 (faslfile)))
+		  (t (load exprfile)
+		     exprfile))))
+
+(defun CLOAD fexpr (filespec)
+       ;; for ease of conversion from old LEDIT
+       (let ((defun t))				      
+	    (load (mergef (mergef filespec (cons '* '>)) defaultf))))
+
+(defun LEDIT-TTYINT (fileobj char)
+       ;; intended to be put on control character, e.g.
+       ;; (sstatus ttyint 5 'ledit-ttyint)
+       (nointerrupt nil)
+       (tyi fileobj)					;gobble up control char
+       (apply 'ledit
+	      (cond ((= (boole 1 127. (tyipeek nil fileobj)) 32.)	;note masking for 7 bit
+		     (tyi fileobj)			;gobble space
+		     ;; if space typed then just (ledit)
+		     nil)
+		    (t (let ((s (read fileobj)))
+			    (cond ((atom s)(list s))	;atom is taken as tag
+				  (t s)))))))		;list is filename
+
+(defun LEDIT fexpr (spec)
+       ;; if given one arg, is tag to be searched for (using FIND FILE)
+       ;; if more than one arg, taken as file name to find (may be newio or oldio form)
+       (let ((newjob (cond ((not (job-exists-p (status uname) ledit-jname))
+			    (setq ledit-jname-altj nil)
+			    (setq ledit-valret nil)
+			    (mapcan 'exploden (list '/
+'|L| ledit-loadfile '/
+'|G|)))))
+	     (firstcall)
+	     (atomvalret))
+
+	    (and ledit-pre-teco-func (funcall ledit-pre-teco-func spec))
+
+	    (or ledit-jname-altj			;memoize for fast calls later
+		(setq ledit-jname-altj (mapcan 'exploden (list '/
+ ledit-jname '|J|))
+		      firstcall t))
+
+	    (cond ((and ledit-valret (null spec))	;go to teco in common case
+		   (valret ledit-valret))
+
+		  (t
+		   (setq atomvalret (maknam (nconc
+
+		      (list 23.)			;ctl-W
+	              (append ledit-jcl nil)		;set own jcl line to nil
+		      (append ledit-jname-altj nil)	;$J to ledit job
+		      (append ledit-jcl nil)		;set jcl line for teco
+
+		      (and newjob			;for new job only
+			  (mapcan 'exploden	        
+				   (list '|F~EDITOR TYPELEDIT"NMMLOAD LIBRARY|
+					 ledit-library '|'|)))
+
+		      (and firstcall			;for first call only
+			   (append ledit-lisp-mode nil))
+
+		      (and firstcall ledit-tags		;for first call only
+			   (mapcan 'exploden
+				   (list ledit-tags-find-file
+					 '|MMVISIT TAG TABLE| ledit-tags '/)))
+		      
+		      (nconc (append ledit-lisp-jname nil)	;tell teco lisp's job name
+			     (exploden (status jname))	
+			     (list 27.))		;note 27. = altmode
+
+		      (cond ((= (length spec) 1)			;tag
+			     (nconc (append ledit-find-tag nil)
+				    (exploden (car spec))
+				    (list 27.)))	
+			    ((> (length spec) 1)	;file name
+			     (nconc (append ledit-find-file nil)
+				    (exploden (namestring (mergef spec defaultf)))
+				    (list 27.))))
+		      (or newjob ledit-proceed))))	;start new job or proceed old one
+	    
+		   (and (not firstcall)(not newjob)(null spec)
+			(setq ledit-valret atomvalret))	;memoize common simple case
+
+		   (valret atomvalret)))				;go to teco
+	    '*))
+
+(comment READING CODE BACK FROM TECO)
+
+(defun LEDIT-TTY-RETURN (unused)
+       ;; this function called by tty-return interrupt
+       ;; check JCL to see if it starts with LEDIT-JNAME
+       ;; if so, rest of JCL is filename to be read in
+       ;; note: need to strip off trailing <cr> on jcl
+       (declare (fixnum i))
+       (let ((jcl (status jcl)))
+         (cond ((and jcl
+		     (setq jcl (errset (readlist (nreverse (cdr (nreverse jcl)))) nil))
+		     (not (atom (setq jcl (car jcl))))
+		     (eq (car jcl) ledit-jname))
+
+	        (valret '|:JCL/
+P|)							;clear jcl
+		(cursorpos 'c)
+		(nointerrupt nil)
+
+		(and ledit-post-teco-func (funcall ledit-post-teco-func (cadr jcl)))
+
+         (cond ((cadr jcl)				;if non-null then read in file
+		;; read in zapped forms
+		(let ((file (open (cadr jcl) 'in)))
+		     (princ '|;Reading from |)(prin1 ledit-jname)
+		     ;; Read-Eval-Print loop
+		     (do ((form (read file ledit-eof) (read file ledit-eof)))
+			 ((eq form ledit-eof)(close file)
+					     (and ledit-deletef (deletef file)))
+			 (and ledit-pre-eval-func
+			      (setq form (funcall ledit-pre-eval-func form)))
+			 ;; check if uuolinks might need to be snapped
+			 (let ((p (memq (car (getl (cadr form)
+						   '(expr subr fexpr fsubr lsubr)))
+					     '(subr fsubr lsubr))))
+			      (print (eval form))
+			      (cond ((and p
+					  (memq (car (getl (cadr form)
+							   '(expr subr fexpr fsubr lsubr)))
+						'(expr fexpr)))
+				     (sstatus uuolinks)
+				     (princ '|	; sstatus uuolinks|))))))))
+	
+         (terpri)
+	 (princ '|;Edit Completed|)
+	 (terpri)))))
+
+(comment UTILITIES)
+
+(defun LEDIT-AGELIST (file)
+       ((lambda (plist)
+		(nconc (get plist 'credate)(get plist 'cretime)))
+	(car (directory (list file) '(credate cretime)))))
+
+
+(defun LEDIT-OLDERP (file1 file2)
+       (do ((age1 (ledit-agelist file1)(cdr age1))
+	    (age2 (ledit-agelist file2)(cdr age2)))
+	   ((null age1) nil)
+	   (cond ((< (car age1)(car age2))(return t))
+		 ((> (car age1)(car age2))(return nil)))))
+
+;;Lap courtesy of GLS.
+
+(declare (setq ibase 8.))
+
+(LAP JOB-EXISTS-P SUBR)
+(ARGS JOB-EXISTS-P (NIL . 2))	;ARGS ARE UNAME AND JNAME, AS SYMBOLS
+	(PUSH P B)
+	(SKIPN 0 A)		;NULL UNAME => DEFAULT TO OWN UNAME
+	(TDZA TT TT)		;ZERO UNAME TELLS ITS TO DEFAULT THIS WAY
+	(PUSHJ P SIXMAK)	;CONVERT UNAME TO SIXBIT
+	(PUSH FXP TT)
+	(POP P A)
+	(PUSHJ P SIXMAK)	;CONVERT JNAME TO SIXBIT
+	(POP FXP T)		;UNAME IN T, JNAME IN TT
+	(MOVEI A 'NIL)
+	(*CALL 0 JEP43)		;SEE IF JOB EXISTS
+	(POPJ P)		;NO - RETURN NIL
+	(*CLOSE 0)		;YES - CLOSE THE CHANNEL
+	(MOVEI A 'T)		; AND RETURN T
+	(POPJ P)
+JEP43	(SETZ)
+	(SIXBIT OPEN)
+	(0 0 16 5000)		;CONTROL BITS: IMAGE BLOCK INPUT/INSIST JOB EXISTS
+	(0 0 0 1000)		;CHANNEL # - 0 IS SAFE IN BOTH OLDIO AND NEWIO
+	(0 0 (% SIXBIT USR))	;DEVICE NAME (USR)
+	(0 0 T)			;UNAME
+	(0 0 TT 400000)		;JNAME
+NIL 
+
+
+
diff --git a/src/libdoc/stacks.gjc1 b/src/libdoc/stacks.gjc1
new file mode 100644
index 00000000..b5e32ab4
--- /dev/null
+++ b/src/libdoc/stacks.gjc1
@@ -0,0 +1,245 @@
+;-*-lisp-*-
+;;; George Carrette -GJC. 10:22am  Tuesday, 9 September 1980
+
+(herald stacks)
+
+(eval-when (compile eval)
+	   (or (status feature 'alan/;struct)
+	       (load 'alan/;struct)))
+
+;;; Stack implementations in maclisp.
+;;; I have carefully timed these, see the examples at the end of the file.
+;;; These operations take slightly longer than the equivalent list
+;;; operations. However, under conditions where much static consing is
+;;; going on, that is, when much list structure exists through more than
+;;; one GC, (.e.g. Lisp Readers, tokenizers, parsers, assemblers), using
+;;; these stacks and allocating with the amount of static consing in mind
+;;; will save huge amounts of time otherwise spent in GC.
+
+;;; there is the possibilty of lap coding some of these.
+
+(eval-when (compile eval load)
+	   (comment Entry Points)
+	   (cond ((status feature complr)
+		  (*expr (fixnum (stack%-pop nil) (stack%-top nil))
+			 stack-zero stack%-zero
+			 stack%-push stack%-empty-p
+			 stack-push stack-pop stack-empty-p stack-top)
+		  (*lexpr make-stack% make-stack))))
+
+;;; Other possible implementations include hacks for reclaiming list
+;;; structure, through the use of RECLAIM, which puts an object back
+;;; on its free-list, or by keeping around structure and using RPLACD/RPLACA.
+;;; Both of these have disadvantages, RECLAIM in dangerousness, and
+;;; RPLAC in pointer chasing time.
+
+;;; You might try HUNKS in multics maclisp, on the PDP10 I don't always
+;;; want to use hunks at run-time, and type NIL arrays are almost as good.
+
+(eval-when (compile eval)
+
+(defstruct (stack% named-hunk conc-name
+		    (constructor make-stack%-1))
+	   ; this is a fixnum stack.
+	   array dim dim-inc max-dim)
+
+(defmacro aref% (&rest l) `(arraycall fixnum ,@l))
+(defmacro make-array% (&rest l) `(*array nil 'fixnum ,@l))
+(defmacro adjust-array% (a &rest l) `(*rearray ,a 'fixnum ,@l))
+(defmacro aref  (&rest l) `(arraycall t ,@l))
+(defmacro make-array (&rest l) `(*array nil t ,@l))
+(defmacro adjust-array (a &rest l) `(*rearray ,a t ,@l))
+
+
+(defstruct (stack named-hunk conc-name (constructor make-stack-1))
+	   ; this is a NOTYPE type stack.
+	   array dim sp dim-inc max-dim)
+
+;;; macros for general stack which you may want to use:
+
+(defmacro stack-null (X) `(zerop (stack-sp ,x)))
+
+;;; end of eval-when-compile
+)
+
+
+(defun |stack underflow| (stack)
+       (error '|stack underflow| stack 'wrng-type-arg))
+(defun |stack overflow| (stack)
+       (error '|stack overflow| stack 'wrng-type-arg))
+
+(defun make-stack% (dim &optional
+			(dim-inc (1+ (// dim 10)))
+			(max-dim (* dim 4)))
+       (make-stack%-1 array (make-array% (1+ dim))
+		      dim dim
+		      max-dim max-dim
+		      dim-inc dim-inc))
+
+(defun make-stack (dim &optional
+		       (dim-inc (1+ (// dim 10)))
+		       (max-dim (* dim 4)))
+       (make-stack-1 array (make-array (1+ dim))
+		     dim dim
+		     sp 0
+		     max-dim max-dim
+		     dim-inc dim-inc))
+
+(defun stack%-push (c stack)
+       (declare (fixnum c))
+       (let* ((array (stack%-array stack))
+	      (SP (1+ (aref% array 0))))
+	     (declare (fixnum sp))
+	     (cond ((> SP (stack%-dim stack))
+		    (let* ((dim-inc (stack%-dim-inc stack))
+			   (new-dim (+ (stack%-dim stack) dim-inc)))
+			  (cond ((or (zerop dim-inc)
+				     (> new-dim (stack%-max-dim stack)))
+				 (stack%-push
+				  c
+				  (|stack overflow| stack)))
+				(t
+				 (adjust-array% array new-dim)
+				 (setf (stack%-dim stack) new-dim))))))
+	     (setf (aref% array 0) SP)
+	     (setf (aref% array sp) C)
+	     stack))
+
+(defun stack-push (c stack)
+       (let ((array (stack-array stack))
+	     (SP (1+ (stack-sp stack))))
+	    (declare (fixnum sp))
+	    (cond ((> SP (stack-dim stack))
+		   (let* ((dim-inc (stack-dim-inc stack))
+			  (new-dim (+ (stack-dim stack) dim-inc)))
+			 (cond ((or (zerop dim-inc)
+				    (> new-dim (stack-max-dim stack)))
+				(stack-push
+				 c
+				 (|stack overflow| stack)))
+			       (t
+				(adjust-array array new-dim)
+				(setf (stack-dim stack) new-dim))))))
+	     (setf (stack-sp stack) SP)
+	     (setf (aref array sp) C)
+	     stack))
+
+(defun stack%-pop (stack)
+       (let* ((array (stack%-array stack))
+	      (SP (aref% array 0)))
+	     (declare (fixnum sp))
+	     (cond ((plusp sp)
+		    (setf (aref% array 0) (1- SP))
+		    (aref% array sp))
+		   (t
+		    (stack%-pop
+		     (|stack underflow| stack))))))
+
+(defun stack-pop (stack)
+       (let ((sp (stack-sp stack)))
+	    (declare (fixnum sp))
+	    (cond ((plusp sp)
+		   (setf (stack-sp stack) (1- sp))
+		   (aref (stack-array stack) sp))
+		  (t
+		   (stack-pop
+		    (|stack underflow| stack))))))
+
+(defun stack%-top (stack)
+       (let* ((array (stack%-array stack))
+	      (sp (aref% array 0)))
+	     (declare (fixnum sp))
+	     (cond ((zerop sp)
+		    (stack%-top (|stack underflow| stack)))
+		   (t
+		    (aref% array sp)))))
+
+(defun stack-top (stack)
+       (cond ((zerop (stack-sp stack))
+	      (stack-top (|stack underflow| stack)))
+	     (t
+	      (aref (stack-array stack) (stack-sp stack)))))
+
+(defun stack%-empty-p (stack)
+       (zerop (aref% (stack%-array stack) 0)))
+
+(defun stack-empty-p (Stack)
+       (zerop (stack-sp stack)))
+
+(defun stack%-zero (stack)
+       (setf (aref% (stack%-array stack) 0) 0)
+       stack)
+
+(defun stack-zero (stack)
+       (setf (stack-sp stack) 0)
+       stack)
+
+;;; more esoteric operations, and ha! these you can't do efficiently
+;;; with lists.
+
+(defun stack-ref (stack ind)
+       (let ((n (- (stack-sp stack) ind)))
+	    (cond ((plusp n)
+		   (aref (stack-array stack) n))
+		  (t
+		   (stack-ref (|stack underflow| stack) ind)))))
+
+(defun stack-set (val stack ind)
+       (let ((n (- (stack-sp stack) ind)))
+	    (cond ((plusp n)
+		   (setf (aref (stack-array stack) n) val))
+		  (t
+		   (stack-set val (|stack underflow| stack) ind)))))
+
+
+
+(eval-when (compile eval)
+	   (if (not (boundp 'test-cases)) (setq test-cases nil))
+	   (defmacro test-cases (&rest l)
+		     (cond (test-cases
+			    `(progn 'compile ,@l))
+			   (t nil))))
+
+(test-cases
+
+(defun empty%-p-test (s n)
+       (do ((foo))
+	   ((zerop (setq n (1- n)))
+	    (stack%-empty-p s))
+	   (setq foo (stack%-empty-p s))))
+
+(defun push%-test (s m)
+       (do ()
+	   ((zerop (setq m (1- m)))
+	    (stack%-push m s))
+	   (stack%-push m s)))
+
+(defun pop%-test (s m)
+       (do ()
+	   ((zerop (setq m (1- m)))
+	    (stack%-pop s))
+	   (stack%-pop s)))
+
+(defun push-pop%-test (s m)
+       ; see Sussman and Steele, RACKS
+       (DO ()
+	   ((zerop (setq m (1- m)))
+	    (stack%-push m s)
+	    (stack%-pop m s))
+	   (stack%-push m s)
+	   (stack%-pop m s)))
+
+(defun empty-list-test (s n)
+       (do ((foo))
+	   ((zerop (setq n (1- n)))
+	    (null s))
+	   ; even complr knows that (null s) for effect is losing.
+	   (setq foo (null s))))
+
+(defun loopn (n)
+       (do ()
+	   ((zerop (setq n (1- n))) nil)))
+
+; end of test cases.
+
+)
\ No newline at end of file
diff --git a/src/z/timer.99 b/src/z/timer.99
new file mode 100644
index 00000000..ae9e2d0d
--- /dev/null
+++ b/src/z/timer.99
@@ -0,0 +1,520 @@
+; -*- MIDAS -*-
+
+TITLE SUBR TIMER PACKAGE
+
+.FASL
+IF1,.INSRT SYS:.FASL DEFS
+
+;;; THIS FILE CONTAINS THE FOLLOWING FUNCTIONS:
+
+; TIME-FUNCTION   -- TAKES A SYMBOL WITH SUBR, LSUBR, OR FSUBR PROP TO TIME
+; TIME-SUBR	  -- TAKES A SUBR POINTER AND A SYMBOL, TO TIME THE SUBR
+; TIME-LSUBR	  -- TAKES AN LSUBR POINTER AND A SYMBOL, TO TIME THE LSUBR
+; UNTIME-FUNCTION -- TAKES A SYMBOL, TO UNTIME THE ASSOCIATED FUNCTION
+; INIT-TIMER	  -- INITIALIZE TIMER.  SHOULD BE CALLED EACH TIME
+;		     BEFORE RUNNING CODE, TO BE SURE THAT EACH FUNCTION IS
+;		     TIMED, AND THAT THE COUNTS/TIMES START AT 0
+; SET-TIMER	  -- MAKES SURE ALL PROBES ARE IN PLACE.  SHOULD BE DONE
+;		     AFTER QUITTING OR ERRORS, IF INIT-TIMER IS NOT TO BE DONE
+; GET-ALL-TIMES	  -- TAKES NO ARGUMENTS, AND RETURNS AN ALIST OF TIMINGS.
+;		     (SYMBOL CALL-COUNT MICROSECONDS REALTIME=SECONDS)
+; GET-TIME	  -- TAKES SINGLE ARGUMENT, OF SYMBOL OR SUBR-POINTER, AND
+;		     RETURNS (CALL-COUNT MICROSECONDS REALTIME-SECONDS)
+; UNTIME	  -- REMOVES ALL FUNCTIONS FROM THE TABLE.
+
+FSYMB=:0			   ;Symbol for function being timed
+				   ; [*NOTE*  THIS SYMBOL WILL NOT BE GC
+				   ;	      PROTECTED, SO DON'T DELETE IT'S
+				   ;	      PLIST OR IT COULD GO AWAY!!
+				   ;	      (NOT VERY DAMNED LIKELY!)]
+FCOUNT=:1			   ;Count of number of times function called
+FTIME=:2			   ;runtime of function, in units of 4 uS.
+FETIME=:3
+FSUBR=:4			   ;SUBR ptr to function
+FJSP=:5
+FINST=:6			   ;First instruction of function, for
+				   ;clobbering purposes.
+FINST0=:7			   ;Second instruction of function, for
+				   ;clobbering purposes.
+ENTSIZ=:8			   ;Minimum size of each entry.
+
+.GLOBAL SEGLOG
+
+VERPRT TIMER
+
+.SXEVAL (SSTATUS FEATURE TIMER)
+
+;;; TAKES A SYMBOL, TO STORE IT AND IT'S SUBR/LSUBR/FSUBR PTR IN ARRAY SLOT.
+
+.ENTRY TIME-FUNCTION SUBR 002
+
+	JSP T,SYMBP		   ;MAKE SURE IT'S A SYMBOL
+	MOVE F,[JSP TT,FHANDL]	   ;HANDLER FOR SUBR'S AND FSUBRS
+	PUSHJ P,FGET		   ;GET THE SUBR-PROPERTY IN B
+	  MOVE F,[JSP TT,LHANDL]   ;HANDLER FOR LSUBRS (LOSE!)
+TIMEFN:	PUSH P,A
+	PUSH P,B
+	PUSH P,F
+	PUSH P,T
+	
+	PUSHJ P,UNPUR		   ;  UNPURIFY IT!
+	HLR T,SCALL1		   ;CHECK THE CALL .FUNCTION RUNTIME'S
+	CAIN T,(PUSHJ P,)	   ;HAVE THEY BEEN SMASHED?
+	  JRST SETUP1		   ;  YES, DON'T BOTHER DOING IT AGAIN!
+	JSP T,SPECBIND
+	0,,.SPECIAL NOUUO	   ;MAKS SURE THAT THE SMASHING HAPPENS
+	XCT SCALL1		   ;NO, SMASH THE BEGGARS
+	XCT SCALL2
+	XCT SCALL3
+	XCT SCALL4
+	XCT TCALL1
+	XCT TCALL2
+	XCT TCALL3
+	XCT TCALL4
+	PUSHJ P,UNBIND		   ;AND UNBIND NOUUO
+
+SETUP1:	POP P,T			   ;AND RESTORE OUR INFO
+	POP P,F
+	POP P,B
+	POP P,A
+LOCKTOPOPJ			   ;LOCK OUT INTERRUPTS SO WE CAN WIN!
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P,FIND		   ;FIND IT IF IT'S ALREADY THERE
+	  CAIA			   ;  NOT THERE, GET A FREE ONE
+	    JRST FOUND		   ;    IT'S THERE, WIN!
+	PUSHJ P,GETFRE		   ;GET A FREE ENTRY
+FOUND:	MOVEM B,FSUBR(TT)	   ;STORE OUR POINTER
+	SETZM FTIME(TT)		   ;NO TIME YET
+	SETZM FETIME(TT)
+	SETZM FCOUNT(TT)	   ;NO CALLS YET
+	MOVE R,(B)		   ;GET THE INSTRUCTIONS WE'LL CLOBBER
+	MOVEM R,FINST(TT)	   ;AND REMEMBER THEM
+	MOVE R,1(B)
+	MOVEM R,FINST0(TT)
+	MOVEM F,(B)		   ;CLOBBER! WE ALREADY UNPURIFIED!
+	MOVEM F,1(B)
+	MOVEM F,FJSP(TT)	   ;AND REMEMBER OUR CLOBBERING TYPE
+	MOVEM A,FSYMB(TT)	   ;SAVE OUR SYMBOL
+	MOVEI A,.ATOM T		   ;T !!
+	POPJ P,
+
+
+;; (TIME-SUBR <SUBR> <SYMBOL>)
+;; (TIME-LSUBR <SUBR> <SYMBOL>)
+.ENTRY TIME-LSUBR SUBR 002
+	SKIPA F,[JSP TT,LHANDL]	   ;USE LSUBR HANDLER
+.ENTRY TIME-SUBR SUBR 002
+	MOVE F,[JSP TT,FHANDL]	   ;HANDLER FOR SUBR'S AND FSUBRS
+	JSP T,SUBRP
+	EXCH A,B		   ;GET SYMBOL IN A AND SUBR IN B
+	JSP T,SYMBP		   ;MAKE SURE A IS A SYMBOL
+	JRST TIMEFN		   ;GO TIME THE FUNCTION.
+
+;;; TAKES A FUNCTION NAME AND STOPS TIMING IT
+.ENTRY UNTIME-FUNCTION SUBR 002
+LOCKTOPOPJ
+        MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P,FIND
+	  JRST [SETZ A, ? POPJ P,] ;NOT THERE, RETURN NIL
+	MOVE T,FSUBR(TT)	   ;GET THE LOCATION OF THE ROUTINE
+	MOVE R,FINST(TT)	   ;AND THE INSTRUCTIONS THAT GOES THERE
+	MOVEM R,(T)		   ;AND RESTORE THEM TO NORMAL
+	MOVE R,FINST0(TT)
+	MOVEM R,1(T)
+	SETZM FSUBR(TT)		   ;SO FFIND DOESN'T FIND THIS SLOT
+	SETZM FSYMB(TT)		   ;SO FIND DOESN'T FIND THIS SLOT
+	MOVEI A,.ATOM T
+	POPJ P,
+
+;;; INITIALIZES THE FUNCTION-TIMES-ARRAY TO ZERO TIMES AND LOCKS CLEARED.
+.ENTRY INIT-TIMER SUBR 001
+LOCKTOPOPJ
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P, GETPTR		   ;GET A POINTER TO THE ARRAY
+FIN0:	SKIPN R,FSUBR(TT)	   ;IS THERE A ROUTINE HERE?
+	  JRST FIN1		   ;  NO, JUST GO ON TO THE NEXT ONE
+	SETZM FTIME(TT)		   ;CLEAR OUT DATA
+	SETZM FETIME(TT)
+	SETZM FCOUNT(TT)
+	MOVE T,FJSP(TT)		   ;GET CLOBBERING INSTRUCTION
+	MOVEM T,(R)		   ;CLOBBER THE INSTRUCTION IN CASE OF ^G
+	MOVEM T,1(R)
+FIN1:	ADD TT,D
+	JUMPL TT,FIN0
+	MOVEI A,.ATOM T
+	POPJ P,
+
+;;; MAKES SURE THAT ALL PROBES ARE IN.
+.ENTRY SET-TIMER SUBR 001
+LOCKTOPOPJ
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P, GETPTR		   ;GET A POINTER TO THE ARRAY
+SIN0:	SKIPN R,FSUBR(TT)	   ;IS THERE A ROUTINE HERE?
+	  JRST SIN1		   ;  NO, JUST GO ON TO THE NEXT ONE
+	MOVE T,FJSP(TT)		   ;GET CLOBBERING INSTRUCTION
+	MOVEM T,(R)		   ;CLOBBER THE INSTRUCTION IN CASE OF ^G
+	MOVEM T,1(R)
+SIN1:	ADD TT,D
+	JUMPL TT,SIN0
+	MOVEI A,.ATOM T
+	POPJ P,
+
+;;; MAKES SURE THAT ALL PROBES ARE IN.
+.ENTRY UNTIME SUBR 001
+LOCKTOPOPJ
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P, GETPTR		   ;GET A POINTER TO THE ARRAY
+	SETZ A,			   ;CONS UP OUR RETURN LIST HERE.
+UN0:	SKIPN R,FSUBR(TT)	   ;IS THERE A ROUTINE HERE?
+	  JRST UN1		   ;  NO, JUST GO ON TO THE NEXT ONE
+	MOVE T,FINST(TT)	   ;GET ORIGINAL INSTRUCTION
+	MOVEM T,(R)		   ;AND RESTORE IT
+	MOVE T,FINST0(TT)
+	MOVEM T,1(R)
+	SETZB B,FSUBR(TT)	   ;CLEAR OUT THE RELEVANT FIELDS
+	EXCH B,FSYMB(TT)	   ;AND RECOVER THE SYMBOL
+	EXCH A,B		   ;TO CONS ONTO OUR RETURN VALUE
+	JSP T,%CONS
+UN1:	ADD TT,D
+	JUMPL TT,UN0
+	POPJ P,
+
+;;; RETURNS A ALIST OF TIMES
+.ENTRY GET-ALL-TIMES SUBR 001
+LOCKTOPOPJ
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P,GETPTR		   ;GET POINTER TO THE ARRAY
+	SETZ AR1,		   ;GETS ALIST
+	MOVE F,TT		   ;F GETS POINTER TO ARRAY
+AFUN0:	SKIPN FSYMB(F)		   ;IS THERE A FUNCTION HERE?
+	  JRST AFUN1		   ;  NO, JUST GRAB NEXT
+	PUSHJ P,FUNCON		   ;CONS UP DATA ON FUNCTION
+	MOVEI B,(A)
+	MOVE A,FSYMB(F)		   ;CONS ON THE SYMBOL TO THE DATA
+	JSP T,%CONS
+	MOVE B,AR1		   ;AND CONS THAT ONTO THE ALIST
+	JSP T,%CONS
+	MOVE AR1,A
+AFUN1:	ADD F,D			   ;NEXT ENTRY
+	JUMPL F,AFUN0
+	MOVE A,AR1		   ;RETURN OUR ALIST
+	POPJ P,
+
+;;; TAKES IN F THE POINTER TO THE ENTRY IN THE TABLE, RETURNS IN A A
+;;; DESCRIPTION.
+FUNCON: MOVE TT,FETIME(F)	   ;GET REAL TIME AS FLONUM
+	JSP T,FLCONS		   ;AND CONS IT UP
+	JSP T,%NCONS		   ;NCONS IT
+	MOVEI B,(A)
+	MOVE TT,FTIME(F)	   ;THE RUN TIME IN uS.
+	JSP T,FXCONS
+	JSP T,%CONS
+	MOVEI B,(A)
+	MOVE TT,FCOUNT(F)	   ;GRAB THE COUNT
+	JSP T,FXCONS
+	JSP T,%CONS
+	POPJ P,
+
+
+;;; This returns the time so far for a given function.
+
+.ENTRY GET-TIME SUBR 002
+        MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY 
+	PUSHJ P,FIND		   ;FIND THE ENTRY
+	  JRST [SETZ A, ? POPJ P,] ;  NOT THERE!
+	MOVEI F,(TT)		   ;F GETS POINTER TO THE ENTRY
+	JRST FUNCON		   ;CONS UP THE INFO ON THE FUNCTION AND RETURN
+
+
+;;; GETFRE FINDS A FREE ENTRY IN THE TABLE, SKIPING IF SUCCESSFUL.
+
+GETFRE:	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P,GETPTR		   ;GET AOBJN PTR TO ARRAY DATA
+GETFR0:	SKIPN T,FSYMB(TT)	   ;IS THIS ONE FREE?
+	  POPJ P,		   ;  YES, USE IT!
+	ADD TT,D		   ;NEXT ENTRY
+	JUMPL TT,GETFR0
+	
+	PUSH P,A		   ;DON'T LET THE *REARRAY CLOBBER AC'S!
+	PUSH P,B		   ;A HAS ATOM, B HAS SUBR, AND F HAS HANDLER
+	PUSH FXP,F
+
+	STRT 0,[SIXBIT/^M;GROWING ARRAY -- TIME-FUNCTION^M!/
+]
+				   ;FAILED, GET BIGGER ARRAY
+	PUSH P,[GETFR1]		   ;RETURN TO GETFRE AFTER *REARRAYING
+	PUSH P,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSH P,[.ATOM FIXNUM ]
+	MOVE TT,@-1(P)		   ;GET THE ASAR
+	MOVE T,3(TT)		   ;GET THE FIRST DIMENSION
+	ADDI T,10.		   ;AND GROW IT SOME
+	PUSH FXP,T		   ;AND MAKE IT INTO A FIXNUM
+	PUSH P,FXP
+	PUSH FXP,4(TT)		   ;GET THE SECOND DIMENTION
+	PUSH P,FXP
+	MOVNI T,4		   ;3 ARGUMENTS
+	JCALL 16,.FUNCTION *REARRAY
+GETFR1:	SUB FXP,[2,,2]
+	POP FXP,F
+	POP P,B
+	POP P,A
+	JRST GETFRE
+
+
+;;; FIND GIVEN SYMBOL
+FIND:	PUSHJ P,GETPTR		   ;GET AOBJN PTR TO ARRAY DATA
+FIND0:	CAMN A,FSYMB(TT)
+	  JRST POPJ1		   ;  FOUND IT, SKIP!
+	ADD TT,D
+	JUMPL TT,FIND0		   ;NOT FOUND YET?
+	POPJ P,			   ;FAILED, DON'T SKIP
+
+;;; FIND GIVEN SUBR POINTER
+
+FFIND:	PUSHJ P,GETPTR		   ;GET AOBJN PTR TO ARRAY DATA
+	MOVEI R,-1(C)		   ;R IS PREVIOUS LOCATION, IN CASE OF
+				   ;NCALL FOO ENTERING AN FOO+1
+FFIND0:	CAMN C,FSUBR(TT)
+	  JRST POPJ1		   ;  FOUND IT, SKIP!
+	CAMN R,FSUBR(TT)
+	  JRST POPJ1
+	ADD TT,D
+	JUMPL TT,FFIND0		   ;NOT FOUND YET?
+	POPJ P,			   ;FAILED, DON'T SKIP
+
+;;; GETS CALLED WITH ADDRESS OF ROUTINE TO CALL IN FREEAC, CLOBBERS ITS
+;;; FIRST INSTRUCTION BACK AGAIN FROM ITS ENTRY IN FUNCTION-TIMES-ARRAY
+;;; AND CALLS IT, AND RE-CLOBBERS TO JSP TT,FHANDL ON RETURN.
+;;; IT COUNTS THE CALLS, AND THE TIME SPENT IN THE FUNCTION.
+
+FHANDL:
+LOCKI
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSH P,C
+	MOVEI C,(TT)-1		   ;C GETS SUBR POINTER TO LOOK UP
+	PUSHJ P,FFIND		   ;FIND THE SLOT WITH THIS SUBR POINTER
+	  .LOSE			   ;  HUH?  WE'RE WEDGED!
+
+	MOVE R,FINST(TT)	   ;GET THE OLD INSTRUCTIONS
+	MOVEM R,(C)		   ;AND RESTORE THEM TO RIGHTFUL HOME
+	MOVE R,FINST0(TT)
+	MOVEM R,1(C)
+
+	HRRZ T,TTSAR(T)		   ;CONVERT TT TO ARRAY OFFSET
+	SUB TT,T
+	HRRZ TT,TT
+	PUSH FLP,TT		   ;SAVE THE ARRAY INDEX
+	
+UNLOCKI	
+
+TCALL1:	NCALL 0,.FUNCTION TIME	   ;AND GET REAL TIME
+	PUSH FLP,TT
+
+SCALL1:	NCALL 0,.FUNCTION RUNTIME  ;GET RUNTIME
+	PUSH FLP,TT		   ;SAVE IT FOR LATER
+	
+
+	MOVEI TT,(C)		   ;GET ENTRY PC IN TT AGAIN
+	POP P,C			   ;AND RESTORE THE STACK
+
+	PUSHJ P,(TT)		   ;CALL OUR RESTORED FUNCTION
+
+
+SCALL2:	NCALL 0,.FUNCTION RUNTIME  ;GET OUR RUN TIME
+	POP FLP,R		   ;GET THE OLD TIME
+	SUB TT,R		   ;FIND DIFFERENCE
+	PUSH FXP,TT		   ;SAVE IT ACROSS THE CALL TO TIME
+
+TCALL2:	NCALL 0,.FUNCTION TIME	   ;GET OUR RUN TIME
+	POP FXP,R		   ;RECOVER OUR OLD DIFFERENCE RUNTIM
+	POP FLP,F		   ;GET THE OLD TIME
+	FSBR TT,F		   ;FIND DIFFERENCE
+	MOVE F,TT		   ;AND PUT IN A LESS TEMPORARY AC
+LOCKI
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P,GETPTR		   ;GET POINTER TO ARRAY DATA
+	ADD TT,(FLP)		   ;AND POINT TO ENTRY
+
+	ADDM R,FTIME(TT)	   ;ADD THE TIME TO THE TOTAL
+	FSBRM F,FETIME(TT)	   ;AND THE RUN TIME
+
+	AOS FCOUNT(TT)		   ;COUNT THIS CALL
+
+	MOVE T,FJSP(TT)		   ;GET INSTRUCTION TO CLOBBER WITH
+	MOVE R,FSUBR(TT)	   ;AND WHERE IT GOES
+	MOVEM T,(R)		   ;CLOBBER!
+	MOVEM T,1(R)
+
+	POP FLP,TT		   ;ALIGN THE PDL
+
+UNLOCKI
+
+	POPJ P,
+
+;;; LSUBR HANDLER.  LIKE FHANDL, BUT PUSHES CALLED ROUTINE'S RETURN ADDRESS 
+;;; ON FXP, AND CLOBBERS IT TO POINT TO THE LHANDL CONTINUATION.
+
+LHANDL:
+LOCKI
+	PUSH P,T		   ;SAVE OUR ARGUMENT
+	MOVEI C,(TT)-1		   ;C GETS SUBR POINTER TO LOOK UP
+
+	MOVEI TT,(P)-1		   ;CALCULATE ADDRESS OF RETURN ADDRESS
+	ADD TT,(P)
+	MOVE T,(TT)		   ;T GETS RETURN ADDRESS
+	PUSH FLP,T		   ;SAVE THE REAL RETURN ADDRESS
+	MOVEI T,LHNDLC		   ;AND CLOBBER TO BE OUR CONTINUATION
+	MOVEM T,(TT)
+
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+	PUSHJ P,FFIND		   ;FIND THE SLOT WITH THIS SUBR POINTER
+	  .LOSE			   ;  HUH?  WE'RE WEDGED!
+
+	MOVE R,FINST(TT)	   ;GET THE OLD INSTRUCTIONS
+	MOVEM R,(C)		   ;AND RESTORE THEM TO RIGHTFUL HOME
+	MOVE R,FINST0(TT)
+	MOVEM R,1(C)
+
+	HRRZ T,TTSAR(T)		   ;CONVERT TT TO ARRAY OFFSET
+	SUB TT,T
+	HRRZ TT,TT
+	PUSH FLP,TT		   ;SAVE THE ARRAY INDEX
+
+UNLOCKI	
+	PUSH P,C
+TCALL3:	NCALL 0,.FUNCTION TIME	   ;GET REAL TIME SO FAR
+	PUSH FLP,TT		   ;SAVE IT FOR LATER
+
+SCALL3:	NCALL 0,.FUNCTION RUNTIME  ;GET RUN TIME SO FAR
+	PUSH FLP,TT		   ;SAVE IT FOR LATER
+
+	POP P,C
+	POP P,T
+	JRST (C)		   ;CALL OUR RESTORED FUNCTION
+
+;;; THE FOLLOWING IS REACHED BY CLOBBER OF THE ROUTINE'S RETURN ADDRESS
+LHNDLC:
+SCALL4:	NCALL 0,.FUNCTION RUNTIME  ;GET OUR RUN TIME
+	POP FLP,R		   ;GET THE OLD TIME
+	SUB TT,R		   ;FIND DIFFERENCE
+	PUSH FXP,TT		   ;SAVE THE DIFFERENCE ACROSS THE CALL TO TIME
+
+TCALL4:	NCALL 0,.FUNCTION TIME	   ;GET OUR REAL TIME
+	POP FXP,R		   ;RECOVER THE OLD RUNTIME DIFFERENCE
+	POP FLP,F		   ;GET THE OLD TIME
+	FSBR TT,F		   ;FIND DIFFERENCE
+	MOVE F,TT		   ;AND MOVE TO A LESS TEMPORARY AC
+	
+
+	MOVE T,.SPECIAL FUNCTION-TIMES-ARRAY
+LOCKI
+	PUSHJ P,GETPTR		   ;GET POINTER TO ARRAY DATA
+	ADD TT,(FLP)		   ;AND POINT TO ENTRY
+
+	ADDM R,FTIME(TT)	   ;ADD THE TIME TO THE TOTAL
+	FADRM F,FETIME(TT)	   ;AND THE REAL TIME.
+
+	AOS FCOUNT(TT)		   ;COUNT THIS CALL
+
+	MOVE T,FJSP(TT)		   ;GET INSTRUCTION TO CLOBBER WITH
+	MOVE R,FSUBR(TT)	   ;AND WHERE IT GOES
+	MOVEM T,(R)		   ;RE-CLOBBER!
+	MOVEM T,1(R)
+UNLOCKI
+	POP FLP,T		   ;FLUSH THE ARRAY LOCATION FROM THE STACK
+	POPJ FLP,		   ;AND RETURN FROM ADDRESS WE SAVED ON FLP
+
+
+;;; GET AOBJN PTR TO STUFF IN ARRAY!
+GETPTR:	MOVEI TT,(T)
+	LSH TT,-SEGLOG		   ;CHECK WHICH SEGMENT IT'S IN
+	HRRZ TT,ST(TT)		   ;INDEX THE SEGMENT TABLE
+	CAIE TT,.ATOM ARRAY	   ;ARRAY?
+	  JRST BADONE
+	HLRZ TT,ASAR(T)		   ;CHECK THE ARRAY TYPE
+	TRNN TT,AS.FX		   ;IS IT AN FIXNUM ARRAY?
+	  JRST BADONE
+	MOVEI TT,@ASAR(T)
+	HRRZ D,4(TT)		   ;SECOND DIMENSION
+	CAIGE D,ENTSIZ		   ;IS THE SECOND DIMENSION BIG ENOUGH?
+	  JRST BADONE		   ;  NO, COMPLAIN
+	HRLI D,1		   ;D IS NOW THING TO ADD TO AOBJN PTR TO
+				   ;ARRAY DATA AREA
+	MOVN TT,3(TT)		   ;Get the size
+	HRLZ TT,TT		   ;make into AOBJN ptr
+	HRR TT,TTSAR(T)		   ;to the actual data area
+	POPJ P,
+
+POPJ1:	AOS (P)
+	POPJ P,
+
+BADONE:
+UNLOCKI
+	MOVE A,.SPECIAL FUNCTION-TIMES-ARRAY
+FAC [BAD VALUE FOR FUNCTION-TIMES-ARRAY, NOT 2D FIXNUM WITH SECOND DIM > 7!]
+	  .LOSE
+
+;; GET THE FUNCTIONAL PROPERTY
+
+FGET:	HRRZ T,(A)		   ;GET PLIST
+FGET0:	HLRZ B,(T)		   ;GET INDICATOR
+	CAIN B,.ATOM SUBR	   ;IS IT A SUBR?
+	  JRST FGET9		   ;  YES, WIN!
+	CAIN B,.ATOM LSUBR	   ;IS IT AN LSUBR?
+	  JRST FGET9L		   ;  YES, WIN, BUT GOTTA HACK DIFFERENTY
+	CAIN B,.ATOM FSUBR	   ;IS IT AN FSUBR?
+	  JRST FGET9		   ;  YES, WIN!
+	HRRZ T,(T)		   ;CDR DOWN PAST VALUE CONS
+	HRRZ T,(T)		   ;TO NEXT INDICATOR CONS
+	JUMPN T,FGET0		   ;IF WE HAVEN'T REACHED THE END, TRY AGAIN
+
+	%WTA NCF		   ;NOT COMPILED FUNCTION
+	JRST FGET
+
+FGET9:	AOS (P)			   ;SKIP RETURN -- NON-LSUBR
+FGET9L:	HRRZ T,(T)		   ;CDR PAST INDICATOR CONS
+	HLRZ B,(T)		   ;RETURN THE VALUE
+	POPJ P,
+
+
+;;; UNPURIFY THE LOCATION IN B
+
+UNPUR:	PUSH FXP,B		   ;(PURIFY <B> <B> NIL)
+	AOS B
+	PUSH FXP,B
+	MOVEI A,-1(FXP)
+	MOVEI B,(FXP)
+	SETZ C,
+	CALL 3,.FUNCTION PURIFY
+	POP FXP,B
+	POP FXP,B
+	POPJ P,
+
+;;; ERROR IF NOT SYMBOL
+SYMBP:	MOVEI TT,(A)		   ;CHECK IF A IS SUBR
+	LSH TT,-SEGLOG		   ;POINT TO SEGMENT
+	HRRZ TT,ST(TT)		   ;LOOK IT UP IN SEGMENT TABLE
+	CAIE TT,.ATOM SYMBOL	   ;SYMBOL?
+          %WTA NCF		   ;  NOT COMPILED FUNCTION
+	JRST (T)
+
+;;; ERROR IF NOT A SUBR
+SUBRP:	MOVEI TT,(A)		   ;CHECK IF A IS SUBR
+	LSH TT,-SEGLOG		   ;POINT TO SEGMENT
+	HRRZ TT,ST(TT)		   ;LOOK IT UP IN SEGMENT TABLE
+	CAIE TT,.ATOM RANDOM	   ;SUBR?
+          WTA [NOT SUBR OBJECT!]
+
+	JRST (T)
+
+NCF:	SIXBIT /NOT COMPILED FUNCTION NAME -- TIME-FUNCTION!/
+
+CONSTANTS
+
+.SXEVAL (ARRAY FUNCTION-TIMES-ARRAY FIXNUM #10 #8 )
+
+.SXEVAL (SETQ FUNCTION-TIMES-ARRAY (GET (QUOTE FUNCTION-TIMES-ARRAY) (QUOTE ARRAY)))
+
+FASEND
+
+