mirror of
https://github.com/PDP-10/its.git
synced 2026-01-19 01:27:05 +00:00
557 lines
22 KiB
Common Lisp
557 lines
22 KiB
Common Lisp
;-*-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))
|