github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-18 05:34:15 +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

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