1
0
mirror of https://github.com/PDP-10/its.git synced 2026-01-19 01:27:05 +00:00
PDP-10.its/src/libdoc/iter.rms19
2018-03-25 10:47:49 +02:00

557 lines
22 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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