github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-26 08:53:29 +00:00
Code Issues Releases Wiki Activity

Added several more LSPLIB packages.

Browse Source 
Resolves #713.
This commit is contained in:
Eric Swenson
2018-03-24 14:44:04 -07:00
committed by Lars Brinkhoff
parent 437de06690
commit 7516530c3d
11 changed files with 4632 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
build/build.tcl
View File

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

104
doc/libdoc/didl.chart Executable file
View File

@@ -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.

46
doc/libdoc/didl.help Executable file
View File

@@ -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)".

234
doc/libdoc/didl.info Executable file
View File

@@ -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.

2527
src/libdoc/didl.dch259 Normal file
View File

File diff suppressed because it is too large Load Diff

44
src/libdoc/dirsiz.gsb2 Normal file
View File

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

64
src/libdoc/hash.gjc1 Normal file
View File

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

556
src/libdoc/iter.rms19 Normal file
View File

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

273
src/libdoc/ledit*.rich17 Normal file
View File

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

245
src/libdoc/stacks.gjc1 Normal file
View File

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

520
src/z/timer.99 Normal file
View File

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