![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to loop.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib|
Return to loop.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-loop-
2: "$Header: /usr/lib/lisp/loop.l,v 1.1 83/01/29 18:38:49 jkf Exp $")
3:
4: ;;; LOOP -*- Mode:LISP; Package:System-Internals; Base:8; Lowercase:T -*-
5: ;;; **********************************************************************
6: ;;; ****** Universal ******** LOOP Iteration Macro ***********************
7: ;;; **********************************************************************
8: ;;; **** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
9: ;;; ******** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *************
10: ;;; **********************************************************************
11:
12: ;;;; LOOP Iteration Macro
13:
14: ;The master copy of this file is on ML:LSB1;LOOP >
15: ;The current Lisp machine copy is on AI:LISPM2;LOOP >
16: ;The FASL and QFASL should also be accessible from LIBLSP; on all machines.
17: ;(Is this necessary anymore? LOOP is now in the Lisp Machine system and
18: ; is accessible on LISP; and distributed with PDP10 Maclisp.)
19: ;Duplicate source is usually also maintained on MC:LSB1;LOOP >
20: ;Printed documentation is available as MIT-LCS Technical Memo 169,
21: ; "LOOP Iteration Macro", from:
22: ; Publications
23: ; MIT Laboratory for Computer Science
24: ; 545 Technology Square
25: ; Cambridge, MA 02139
26: ; the text of which appears in only slightly modified form in the Lisp
27: ; Machine manual.
28:
29: ; Bugs/complaints/suggestions/solicitations-for-documentation to BUG-LOOP
30: ; at any ITS site (MIT-ML preferred).
31:
32:
33: ; **********************************************************************
34: ; *************************** NOTE WELL ********************************
35: ; **********************************************************************
36: ;Incremental compiling of things in this file will generate wrong code
37: ; unless you first evaluate the 'feature' stuff on the next page
38: ; ("readtime environment setup"). (This mainly of Lispm interest.)
39: ;This source sincerely believes that it can run compatibly, WITHOUT ANY
40: ; TEXTUAL MODIFICATIONS AT ALL, in PDP-10 Maclisp, Multics Maclisp, Lisp
41: ; Machine Lisp (Zetalisp), VAX NIL, and Franz Lisp. PLEASE do not make
42: ; changes to this file (the master copy) if you are in any way unsure
43: ; of the implications in a dialect you are not very familiar with; let
44: ; a LOOP maintainer take the responsibility for breaking the master copy
45: ; and maintaining some semblance of sanity among the disparities. Note
46: ; in particular that LOOP also runs in the PDP10 Maclisp -> Vax NIL
47: ; cross-compiler; that environment requires LOOP to produce code which
48: ; can at the same time be interpreted in Maclisp, and compiled for NIL.
49:
50:
51: ; Bootstrap up our basic primitive environment.
52: ; This includes backquote, sharpsign, defmacro, let.
53:
54: (eval-when (eval compile)
55: (cond ((status feature Multics)
56: (defun include-for-multics macro (x)
57: (cons '%include (cdr x))))
58: ('t #-Franz (macro include-for-multics (x) ())
59: #+Franz (defmacro include-for-multics (x) nil))))
60:
61: (include-for-multics lisp_prelude)
62: (include-for-multics lisp_dcls)
63:
64: #+Franz (environment-maclisp)
65:
66:
67: ;;;; Readtime Environment Setup
68:
69: ;Now set up the readtime conditionalization environment. This won't work
70: ; in any compiler that reads the whole file before compiling anything.
71: ; It is a good idea to pretend that case matters in ALL contexts.
72: ; This is in fact true in Franz at the present. Case matters to Multics
73: ; in symbols, except for <frob> in (status feature <frob>).
74: (eval-when (eval compile)
75: #+NIL (progn
76: (defmacro loop-featurep (f)
77: `(featurep ',f target-features))
78: (defmacro loop-nofeaturep (f)
79: `(nofeaturep ',f target-features))
80: (defmacro loop-set-feature (f)
81: `(set-feature ',f target-features))
82: (defmacro loop-set-nofeature (f)
83: `(set-nofeature ',f target-features))
84: )
85: #-NIL (progn
86: (defmacro loop-featurep (f)
87: `(status feature ,f))
88: (defmacro loop-nofeaturep (f)
89: ; Multics doesn't have (status nofeature)...
90: `(not (status feature ,f)))
91: (defmacro loop-set-feature (f)
92: `(sstatus feature ,f))
93: (defmacro loop-set-nofeature (f)
94: ; Does this work on Multics??? I think not but we don't use.
95: `(sstatus nofeature ,f))
96: )
97: ;Note: NEVER in this file is "PDP-10" a valid feature or substring of
98: ; a feature. It is NEVER hyphenated. Keep it that way. (This because
99: ; of continuous lossage with not setting up one or the other of the
100: ; hyphenated/non-hyphenated one.)
101: (cond ((and (loop-featurep PDP10)
102: (loop-featurep NILAID))
103: ;Compiling a PDP10 -> NIL cross-compiling LOOP.
104: ; We check the PDP10 feature first sort of gratuitously so that
105: ; other implementations don't think we are asking about an undefined
106: ; feature name. (Vax-NIL specifically.)
107: (loop-set-feature For-NIL)
108: (loop-set-nofeature For-Maclisp)
109: (loop-set-nofeature For-PDP10)
110: (loop-set-feature Run-in-Maclisp)
111: (loop-set-feature Run-on-PDP10)
112: (loop-set-nofeature Franz))
113: ((and (loop-featurep Maclisp) (loop-nofeaturep For-NIL))
114: ; Standard in-Maclisp for-Maclisp.
115: (loop-set-feature For-Maclisp)
116: (loop-set-feature Run-In-Maclisp)
117: (cond ((loop-nofeaturep Multics)
118: (loop-set-feature For-PDP10)
119: (loop-set-feature PDP10)
120: (loop-set-feature Run-on-PDP10))))
121: ((loop-featurep NIL)
122: ; Real NIL
123: (loop-set-nofeature PDP10)
124: (loop-set-nofeature Multics)
125: (loop-set-nofeature Run-on-PDP10)
126: (loop-set-nofeature For-PDP10)
127: (loop-set-nofeature Run-In-Maclisp)
128: (loop-set-nofeature For-Maclisp))
129: ((loop-featurep Lispm))
130: ((loop-featurep franz)
131: ;The "natural" case of features in franz is all lower.
132: ; Since that is unlike the others used in here, we synonymize
133: ; the obvious other choice.
134: (loop-set-feature Franz))
135: ('t (break loop-implementation-unknown)))
136: (cond ((or (loop-featurep Lispm) (loop-featurep For-PDP10))
137: (loop-set-feature Hairy-Collection))
138: ('t (loop-set-nofeature Hairy-Collection)))
139: (cond ((or (loop-featurep For-NIL) (loop-featurep For-PDP10))
140: (loop-set-feature System-Destructuring))
141: ('t (loop-set-nofeature System-Destructuring)))
142: (cond ((or (loop-featurep For-NIL) (loop-featurep Lispm))
143: (loop-set-feature Named-PROGs))
144: ('t (loop-set-nofeature Named-PROGs)))
145: ;In the following two features, "Local" means the Lisp LOOP will be
146: ; running in, not the one it is being compiled in. "Targeted" means
147: ; the Lisp it will be producing code for. (All from the point of view
148: ; of the running LOOP, you see.)
149: (cond ((or (loop-featurep For-NIL) (loop-featurep Lispm))
150: (loop-set-feature Targeted-Lisp-has-Packages))
151: ('t (loop-set-nofeature Targeted-Lisp-has-Packages)))
152: (cond ((or (loop-featurep Franz) (loop-featurep Run-in-Maclisp))
153: (loop-set-nofeature Local-Lisp-has-Packages))
154: ('t (loop-set-feature Local-Lisp-has-Packages)))
155: (cond ((loop-featurep For-NIL) (loop-set-feature Vector-Destructuring))
156: ('t (loop-set-nofeature Vector-Destructuring)))
157: ;Meaningful-Type-Declarations means that the declarations are (1)
158: ; implemented by the compiler and (2) used for something.
159: ; Assume minimally maclisp-like FIXNUM and FLONUM dcls, for local
160: ; variables or function results.
161: (cond ((loop-featurep Run-in-Maclisp)
162: (loop-set-feature Meaningful-Type-Declarations))
163: ('t (loop-set-nofeature Meaningful-Type-Declarations)))
164: ;Hair for 3600 cross-compilation?
165: (cond ((and (loop-featurep Lispm) (not (loop-featurep 3600.)))
166: (loop-set-feature Loop-Small-Floatp))
167: ('t (loop-set-nofeature Loop-Small-Floatp)))
168: ; -> insert more conditionals here <-
169: ())
170:
171: #+Franz
172: (eval-when (eval compile)
173: (setsyntax #// 143.) ; Make slash be slash
174: (setsyntax #/\ 2.) ; make backslash alphabetic
175: )
176:
177:
178: #+Run-on-PDP10
179: (eval-when (compile)
180: ;Note this hack used when compiled only.
181: ;Its purpose in life is to save a bit of space in the load-time environment,
182: ; since loop doesn't actually need the PDP10 Maclisp doublequoted crocks
183: ; to remember their origin as "strings".
184: (setsyntax #/" 'macro
185: '(lambda ()
186: (do ((ch (tyi) (tyi)) (l () (cons ch l)))
187: ((= ch #/")
188: (list squid (list 'quote (implode (nreverse l)))))
189: (and (= ch #//) (setq ch (tyi)))))))
190:
191:
192: ;;;; Other basic header stuff
193:
194:
195: ; Following isn't needed on Lispm, as loop is installed there (ie, these
196: ; symbols are already in GLOBAL).
197: #+(and Targeted-Lisp-has-Packages (not Lispm))
198: (mapc 'globalize
199: '("LOOP" ; Major macro
200: "LOOP-FINISH" ; Handy macro
201: "DEFINE-LOOP-MACRO"
202: "DEFINE-LOOP-PATH" ; for users to define paths
203: "DEFINE-LOOP-SEQUENCE-PATH" ; this too
204: ))
205:
206: #+(or For-NIL For-PDP10)
207: (herald LOOP)
208:
209:
210: ;;;; Macro Environment Setup
211:
212: ;Wrapper for putting around DEFMACRO etc. forms to determine whether
213: ; they are defined in the compiled output file or not. (It is assumed
214: ; that DEFMACRO forms will be.) Making loop-macro-progn output for loading
215: ; is convenient if loop will have incremental-recompilation done on it.
216: ; (Note, of course, that the readtime environment is NOT set up.)
217:
218: #+Lispm
219: (defmacro loop-macro-progn (&rest forms)
220: `(progn 'compile ,@forms))
221: #-Lispm
222: (eval-when (eval compile)
223: (defmacro loop-macro-progn (&rest forms)
224: `(eval-when (eval compile) ,@forms)))
225:
226:
227: ; Hack up the stuff for data-types. DATA-TYPE? will always be a macro
228: ; so that it will not require the data-type package at run time if
229: ; all uses of the other routines are conditionalized upon that value.
230: (eval-when (eval compile)
231: ; Crock for DATA-TYPE? derives from DTDCL. We just copy it rather
232: ; than load it in, which requires knowing where it comes from (sigh).
233: ;
234: #-Local-Lisp-has-Packages
235: (defmacro data-type? (x) `(get ,x ':data-type))
236: #+Local-Lisp-has-Packages
237: (defmacro data-type? (frob)
238: (let ((foo (gensym)))
239: `((lambda (,foo)
240: ; NIL croaks if () given to GET...
241: (and #+NIL (symbolp ,foo) #-NIL 't
242: (or (get ,foo ':data-type)
243: (and (setq ,foo (intern-soft (get-pname ,foo) ""))
244: (get ,foo ':data-type)))))
245: ,frob))))
246:
247: (declare (*lexpr variable-declarations)
248: ; Multics defaults to free-functional-variable since it is declared
249: ; special & used as function before it is defined:
250: (*expr loop-when-it-variable)
251: (*expr initial-value primitive-type)
252: #+(or Maclisp Franz) (macros t) ; Defmacro dependency
253: #+Run-in-Maclisp
254: (muzzled t) ; I know what i'm doing
255: )
256:
257: #+Run-on-PDP10
258: (declare (mapex ())
259: (genprefix loop/|-)
260: (special squid)
261: #+(and Run-in-Maclisp For-NIL) ; patch it up
262: (*expr stringp vectorp vref vector-length)
263: )
264:
265: #-Run-on-PDP10
266: (declare
267: #+Lispm (setq open-code-map-switch t)
268: #+Run-in-Maclisp (mapex t)
269: #+Run-in-Maclisp (genprefix loop-iteration/|-))
270:
271: #+Run-on-PDP10
272: (mapc '(lambda (x)
273: (or (getl x '(subr lsubr fsubr macro fexpr expr autoload))
274: ; This dtdcl will sort of work for NIL code generation,
275: ; if declarations will ignored.
276: (putprop x '((lisp) dtdcl fasl) 'autoload)))
277: '(data-type? variable-declarations initial-value primitive-type))
278:
279: (loop-macro-progn
280: (defmacro loop-copylist* (l)
281: #+Lispm `(copylist* ,l)
282: #-Lispm `(append ,l ())))
283:
284:
285: ;;;; Random Macros
286:
287: ; Error macro. Note that in the PDP10 version we call LOOP-DIE rather
288: ; than ERROR -- there are so many occurences of it in this source that
289: ; it is worth breaking off that function, since calling the lsubr ERROR
290: ; takes more inline code.
291: (loop-macro-progn
292: (defmacro loop-simple-error (unquoted-message &optional (datum () datump))
293: #+(and Run-In-Maclisp (not Multics))
294: (progn (cond ((symbolp unquoted-message))
295: ((and (not (atom unquoted-message))
296: compiler-state
297: (eq (car unquoted-message) squid)
298: (not (atom (setq unquoted-message
299: (cadr unquoted-message))))
300: (eq (car unquoted-message) 'quote)
301: (symbolp (cadr unquoted-message)))
302: (setq unquoted-message (cadr unquoted-message)))
303: ('t (error '|Uloze -- LOOP-SIMPLE-ERROR|
304: (list 'loop-simple-error
305: unquoted-message datum))))
306: (cond (datump `(loop-die ',unquoted-message ,datum))
307: ('t `(error ',unquoted-message))))
308: #+(or Franz Multics)
309: (progn (or (memq (typep unquoted-message) '(string symbol))
310: (error '|Uloze -- | (list 'loop-simple-error
311: unquoted-message datum)))
312: `(error ,(let ((l (list "lisp: " unquoted-message
313: (if datump " -- " ""))))
314: #+Franz (get_pname (apply 'uconcat l))
315: #-Franz (apply 'catenate l))
316: . ,(and datump (list datum))))
317: #-(or Run-In-Maclisp Franz)
318: `(ferror () ,(if datump (string-append "~S " unquoted-message)
319: unquoted-message)
320: . ,(and datump (list datum)))))
321:
322:
323: #+(and Run-in-Maclisp (not Multics))
324: (defun loop-die (arg1 arg2)
325: (error arg1 arg2))
326:
327:
328: ; This is a KLUDGE. But it apparently saves an average of two inline
329: ; instructions per call in the PDP10 version... The ACS prop is
330: ; fairly gratuitous.
331:
332: #+Run-on-PDP10
333: (progn 'compile
334: (lap-a-list
335: '((lap loop-pop-source subr)
336: (args loop-pop-source (() . 0))
337: (hlrz a @ (special loop-source-code))
338: (hrrz b @ (special loop-source-code))
339: (movem b (special loop-source-code))
340: (popj p)
341: nil))
342: (eval-when (compile)
343: (defprop loop-pop-source 2 acs)
344: ))
345:
346: #-Run-on-PDP10
347: (loop-macro-progn
348: (defmacro loop-pop-source () '(pop loop-source-code)))
349:
350: (loop-macro-progn
351: (defmacro object-that-cares-p (x)
352: #+Lispm `(listp ,x)
353: #+(or NIL PDP10) `(pairp ,x)
354: #-(or Lispm NIL PDP10) `(eq (typep ,x) 'list)))
355:
356:
357: ;;;; Variable defining macros
358:
359: ;There is some confusion among lisps as to whether or not a file containing
360: ; a DEFVAR will declare the variable when the compiled file is loaded
361: ; into a compiler. LOOP assumes that DEFVAR does so (this is needed for
362: ; various user-accessible variables). DEFIVAR is for "private" variables.
363: ; Note that this is moot for Lispm due to incremental-recompilation support
364: ; anyway.
365: ;Multics lcp has some bug whereby DECLARE and (EVAL-WHEN (COMPILE) ...)
366: ; don't get hacked properly inside of more than one level of
367: ; (PROGN 'COMPILE ...). Thus we hack around DEFVAR and DEFIVAR to bypass
368: ; this lossage.
369: ;Franz DEFVAR does not make the declaration on loading, so we redefine it.
370:
371: #+(or Multics Franz)
372: (loop-macro-progn
373: (defmacro defvar (name &optional (init nil initp) documentation
374: &aux (dclform `(and #+Franz (getd 'special)
375: #-Franz (status feature compiler)
376: (special ,name))))
377: ; For some obscure reason, (DECLARE ...) doesn't take effect within 2
378: ; (PROGN 'COMPILE ...)s, but (EVAL-WHEN (COMPILE) ...) does, on Multics.
379: (eval dclform) ; sigh
380: (cond ((not initp) dclform)
381: (t `(progn 'compile
382: ,dclform
383: (or (boundp ',name) (setq ,name ,init)))))))
384:
385: (loop-macro-progn
386: ; A DEFVAR alternative - "DEFine Internal VARiable".
387: (defmacro defivar (name &optional (init () initp))
388: ; The Lispm choice here is based on likelihood of incremental compilation.
389: #+Lispm `(defvar ,name ,@(and initp `(,init)))
390: #+Multics (progn (apply 'special (list name))
391: (if initp `(or (boundp ',name) (setq ,name ,init))
392: `(progn 'compile)))
393: #-(or Lispm Multics)
394: `(progn 'compile
395: (declare (special ,name))
396: . ,(and initp `((or (boundp ',name) (setq ,name ,init)))))))
397:
398: #+Franz
399: ;Defconst is like defvar but always initializes.
400: ; It happens in this case that we really don't care about the global
401: ; declaration on loading, so actually treat it more like DEFIVAR.
402: ; (This is now in Multics and PDP10 Maclisp, thanks to Maclisp Extensions
403: ; Manual.)
404: (loop-macro-progn
405: (defmacro defconst (name init &optional documentation)
406: `(progn 'compile (declare (special ,name)) (setq ,name ,init))))
407:
408:
409:
410: ;;;; Setq Hackery
411:
412: ; Note: LOOP-MAKE-PSETQ is NOT flushable depending on the existence
413: ; of PSETQ, unless PSETQ handles destructuring. Even then it is
414: ; preferable for the code LOOP produces to not contain intermediate
415: ; macros, especially in the PDP10 version.
416:
417: (defun loop-make-psetq (frobs)
418: (and frobs
419: (loop-make-setq
420: (list (car frobs)
421: (if (null (cddr frobs)) (cadr frobs)
422: `(prog1 ,(cadr frobs)
423: ,(loop-make-psetq (cddr frobs))))))))
424:
425: #-System-Destructuring
426: (progn 'compile
427:
428: (defvar si:loop-use-system-destructuring?
429: ())
430:
431: (defivar loop-desetq-temporary)
432:
433: ; Do we want this??? It is, admittedly, useful...
434: ;(defmacro loop-desetq (&rest x)
435: ; (let ((loop-desetq-temporary ()))
436: ; (let ((setq-form (loop-make-desetq x)))
437: ; (if loop-desetq-temporary
438: ; `((lambda (,loop-desetq-temporary) ,setq-form) ())
439: ; setq-form))))
440:
441:
442: (defun loop-make-desetq (x)
443: (if si:loop-use-system-destructuring?
444: (cons (do ((l x (cddr l))) ((null l) 'setq)
445: (or (and (not (null (car l))) (symbolp (car l)))
446: (return 'desetq)))
447: x)
448: (do ((x x (cddr x)) (r ()) (var) (val))
449: ((null x) (and r (cons 'setq r)))
450: (setq var (car x) val (cadr x))
451: (cond ((and (not (atom var))
452: (not (atom val))
453: (not (and (memq (car val)
454: '(car cdr cadr cddr caar cdar))
455: (atom (cadr val)))))
456: (setq x (list* (or loop-desetq-temporary
457: (setq loop-desetq-temporary (gensym)))
458: val var loop-desetq-temporary (cddr x)))))
459: (setq r (nconc r (loop-desetq-internal (car x) (cadr x)))))))
460:
461: (defun loop-desetq-internal (var val)
462: (cond ((null var) ())
463: ((atom var) (list var val))
464: ('t (nconc (loop-desetq-internal (car var) `(car ,val))
465: (loop-desetq-internal (cdr var) `(cdr ,val))))))
466: ); End desetq hackery for #-System-Destructuring
467:
468:
469: (defun loop-make-setq (pairs)
470: (and pairs
471: #-System-Destructuring
472: (loop-make-desetq pairs)
473: #+System-Destructuring
474: (cons (do ((l pairs (cddr l))) ((null l) 'setq)
475: (or (and (car l) (symbolp (car l))) (return 'desetq)))
476: pairs)))
477:
478:
479: (defconst loop-keyword-alist ;clause introducers
480: '(
481: #+Named-PROGs
482: (named loop-do-named)
483: (initially loop-do-initially)
484: (finally loop-do-finally)
485: (nodeclare loop-nodeclare)
486: (do loop-do-do)
487: (doing loop-do-do)
488: (return loop-do-return)
489: (collect loop-do-collect list)
490: (collecting loop-do-collect list)
491: (append loop-do-collect append)
492: (appending loop-do-collect append)
493: (nconc loop-do-collect nconc)
494: (nconcing loop-do-collect nconc)
495: (count loop-do-collect count)
496: (counting loop-do-collect count)
497: (sum loop-do-collect sum)
498: (summing loop-do-collect sum)
499: (maximize loop-do-collect max)
500: (minimize loop-do-collect min)
501: (always loop-do-always or)
502: (never loop-do-always and)
503: (thereis loop-do-thereis)
504: (while loop-do-while or while)
505: (until loop-do-while and until)
506: (when loop-do-when ())
507: (if loop-do-when ())
508: (unless loop-do-when t)
509: (with loop-do-with)))
510:
511:
512: (defconst loop-iteration-keyword-alist
513: `((for loop-do-for)
514: (as loop-do-for)
515: (repeat loop-do-repeat)))
516:
517:
518: (defconst loop-for-keyword-alist ;Types of FOR
519: '( (= loop-for-equals)
520: (first loop-for-first)
521: (in loop-list-stepper car)
522: (on loop-list-stepper ())
523: (from loop-for-arithmetic from)
524: (downfrom loop-for-arithmetic downfrom)
525: (upfrom loop-for-arithmetic upfrom)
526: (below loop-for-arithmetic below)
527: (to loop-for-arithmetic to)
528: (being loop-for-being)))
529:
530: #+Named-PROGs
531: (defivar loop-prog-names)
532:
533: (defvar loop-path-keyword-alist ()) ; PATH functions
534: (defivar loop-named-variables) ; see SI:LOOP-NAMED-VARIABLE
535: (defivar loop-collection-crocks) ; see LOOP-DO-COLLECT etc
536: (defivar loop-variables) ;Variables local to the loop
537: (defivar loop-declarations) ; Local dcls for above
538: (defivar loop-nodeclare) ; but don't declare these
539: (defivar loop-variable-stack)
540: (defivar loop-declaration-stack)
541: #-System-Destructuring
542: (defivar loop-desetq-crocks) ; see loop-make-variable
543: #-System-Destructuring
544: (defivar loop-desetq-stack) ; and loop-translate-1
545: (defivar loop-prologue) ;List of forms in reverse order
546: (defivar loop-before-loop)
547: (defivar loop-body) ;..
548: (defivar loop-after-body) ;.. for FOR steppers
549: (defivar loop-epilogue) ;..
550: (defivar loop-after-epilogue) ;So COLLECT's RETURN comes after FINALLY
551: (defivar loop-conditionals) ;If non-NIL, condition for next form in body
552: ;The above is actually a list of entries of the form
553: ;(cond (condition forms...))
554: ;When it is output, each successive condition will get
555: ;nested inside the previous one, but it is not built up
556: ;that way because you wouldn't be able to tell a WHEN-generated
557: ;COND from a user-generated COND.
558: ;When ELSE is used, each cond can get a second clause
559:
560: (defivar loop-when-it-variable) ;See LOOP-DO-WHEN
561: (defivar loop-never-stepped-variable) ; see LOOP-FOR-FIRST
562: (defivar loop-emitted-body?) ; see LOOP-EMIT-BODY,
563: ; and LOOP-DO-FOR
564: (defivar loop-iteration-variables) ; LOOP-MAKE-ITERATION-VARIABLE
565: (defivar loop-iteration-variablep) ; ditto
566: (defivar loop-collect-cruft) ; for multiple COLLECTs (etc)
567: (defivar loop-source-code)
568: (defvar loop-duplicate-code ()) ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC
569:
570:
571: ;;;; Token Hackery
572:
573: ;Compare two "tokens". The first is the frob out of LOOP-SOURCE-CODE,
574: ;the second a symbol to check against.
575:
576: ; Consider having case-independent comparison on Multics.
577: #+(or Multics Franz)
578: (progn 'compile
579: (defmacro si:loop-tequal (x1 x2)
580: `(eq ,x1 ,x2))
581: (defmacro si:loop-tmember (x l)
582: `(memq ,x ,l))
583: (defmacro si:loop-tassoc (x l)
584: `(assq ,x ,l)))
585:
586:
587: #+Lispm
588: (progn 'compile
589: (defun si:loop-tequal (x1 x2)
590: (and (symbolp x1) (string-equal x1 x2)))
591: (defun si:loop-tassoc (kwd alist)
592: (and (symbolp kwd) (ass #'string-equal kwd alist)))
593: (defun si:loop-tmember (kwd list)
594: (and (symbolp kwd) (mem #'string-equal kwd list))))
595:
596:
597: #+Run-on-PDP10
598: (progn 'compile
599: #+For-NIL
600: (defun si:loop-tequal (x1 x2)
601: (eq x1 x2))
602: #-For-NIL
603: (progn 'compile
604: (eval-when (load compile)
605: (cond ((status feature complr)
606: ; Gross me out!
607: (setq macrolist
608: (cons '(si:loop-tequal
609: . (lambda (x) (cons 'eq (cdr x))))
610: (delq (assq 'si:loop-tequal macrolist)
611: macrolist)))
612: (*expr si:loop-tmember si:loop-tassoc))))
613: (defun si:loop-tequal (x1 x2)
614: (eq x1 x2)))
615: (defun si:loop-tmember (kwd list)
616: (memq kwd list))
617: (defun si:loop-tassoc (kwd alist)
618: (assq kwd alist))
619: )
620:
621: #+(and For-NIL (not Run-in-Maclisp))
622: (progn 'compile
623: ; STRING-EQUAL only accepts strings. GET-PNAME can be open-coded
624: ; however.
625: (defun si:loop-tequal (kwd1 kwd2)
626: (and (symbolp kwd1) (string-equal (get-pname kwd1) (get-pname kwd2))))
627: (defun si:loop-tassoc (kwd alist)
628: (cond ((symbolp kwd)
629: (setq kwd (get-pname kwd))
630: (do ((l alist (cdr l))) ((null l) ())
631: (and (string-equal kwd (get-pname (caar l)))
632: (return (car l)))))))
633: (defun si:loop-tmember (token list)
634: (cond ((symbolp token)
635: (setq token (get-pname token))
636: (do ((l list (cdr l))) ((null l))
637: (and (string-equal token (get-pname (car l)))
638: (return l)))))))
639:
640:
641: #+(or For-PDP10 For-NIL)
642: (eval-when (eval compile) (setq defmacro-displace-call ()))
643:
644: (defmacro define-loop-macro (keyword)
645: (or (eq keyword 'loop)
646: (si:loop-tassoc keyword loop-keyword-alist)
647: (si:loop-tassoc keyword loop-iteration-keyword-alist)
648: (loop-simple-error "not a loop keyword - define-loop-macro" keyword))
649: (subst keyword 'keyword
650: '(eval-when (compile load eval)
651: #+(or For-NIL Run-on-PDP10)
652: (progn (flush-macromemos 'keyword ())
653: (flush-macromemos 'loop ()))
654: #-Run-in-Maclisp
655: (progn
656: #+Franz
657: (putd 'keyword
658: '(macro (macroarg) (loop-translate macroarg)))
659: #-Franz
660: (fset-carefully 'keyword '(macro . loop-translate)))
661: #+Run-in-Maclisp
662: (progn (defprop keyword loop-translate macro))
663: )))
664:
665: #+(or For-PDP10 For-NIL)
666: (eval-when (eval compile) (setq defmacro-displace-call 't))
667:
668: (define-loop-macro loop)
669:
670: #+Run-in-Maclisp
671: (defun (loop-finish macro) (form)
672: ;This definition solves two problems:
673: ; (1) wasted address space
674: ; (2) displacing of a form which might tend to be pure.
675: ; There is little point in macro-memoizing a constant anyway.
676: (and (cdr form) (loop-simple-error "Wrong number of args" form))
677: '(go end-loop))
678:
679: #-Run-in-Maclisp
680: (defmacro loop-finish ()
681: '(go end-loop))
682:
683:
684: (defun loop-translate (x)
685: #-(or For-NIL Run-on-PDP10) (displace x (loop-translate-1 x))
686: #+(or For-NIL Run-on-PDP10)
687: (or (macrofetch x) (macromemo x (loop-translate-1 x) 'loop)))
688:
689:
690: (defun loop-end-testify (list-of-forms)
691: (if (null list-of-forms) ()
692: `(and ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
693: (car list-of-forms)
694: (cons 'or list-of-forms))
695: (go end-loop))))
696:
697: (defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b
698: lastdiff)
699: (do ((l1 (nreverse loop-before-loop) (cdr l1))
700: (l2 (nreverse loop-after-body) (cdr l2)))
701: ((equal l1 l2)
702: (setq loop-body (nconc (delq '() l1) (nreverse loop-body))))
703: (push (car l1) before) (push (car l2) after))
704: (cond ((not (null loop-duplicate-code))
705: (setq loop-before-loop (nreverse (delq () before))
706: loop-after-body (nreverse (delq () after))))
707: ('t (setq loop-before-loop () loop-after-body ()
708: before (nreverse before) after (nreverse after))
709: (do ((bb before (cdr bb)) (aa after (cdr aa)))
710: ((null aa))
711: (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa))
712: ((not (si:loop-simplep (car aa))) ;Mustn't duplicate
713: (return ()))))
714: (cond (lastdiff ;Down through lastdiff should be duplicated
715: (do () (())
716: (and (car before) (push (car before) loop-before-loop))
717: (and (car after) (push (car after) loop-after-body))
718: (setq before (cdr before) after (cdr after))
719: (and (eq after (cdr lastdiff)) (return ())))
720: (setq loop-before-loop (nreverse loop-before-loop)
721: loop-after-body (nreverse loop-after-body))))
722: (do ((bb (nreverse before) (cdr bb))
723: (aa (nreverse after) (cdr aa)))
724: ((null aa))
725: (setq a (car aa) b (car bb))
726: (cond ((and (null a) (null b)))
727: ((equal a b)
728: (loop-output-group groupb groupa)
729: (push a loop-body)
730: (setq groupb () groupa ()))
731: ('t (and a (push a groupa)) (and b (push b groupb)))))
732: (loop-output-group groupb groupa)))
733: (and loop-never-stepped-variable
734: (push `(setq ,loop-never-stepped-variable ()) loop-after-body))
735: ())
736:
737:
738: (defun loop-output-group (before after)
739: (and (or after before)
740: (let ((v (or loop-never-stepped-variable
741: (setq loop-never-stepped-variable
742: (loop-make-variable (gensym) ''t ())))))
743: (push (cond ((not before) `(or ,v (progn . ,after)))
744: ((not after) `(and ,v (progn . ,before)))
745: ('t `(cond (,v . ,before) ('t . ,after))))
746: loop-body))))
747:
748:
749: (defun loop-translate-1 (loop-source-code)
750: (and (eq (car loop-source-code) 'loop)
751: (setq loop-source-code (cdr loop-source-code)))
752: (do ((loop-iteration-variables ())
753: (loop-iteration-variablep ())
754: (loop-variables ())
755: (loop-nodeclare ())
756: (loop-named-variables ())
757: (loop-declarations ())
758: #-System-Destructuring
759: (loop-desetq-crocks ())
760: (loop-variable-stack ())
761: (loop-declaration-stack ())
762: #-System-destructuring
763: (loop-desetq-stack ())
764: (loop-prologue ())
765: (loop-before-loop ())
766: (loop-body ())
767: (loop-emitted-body? ())
768: (loop-after-body ())
769: (loop-epilogue ())
770: (loop-after-epilogue ())
771: (loop-conditionals ())
772: (loop-when-it-variable ())
773: (loop-never-stepped-variable ())
774: #-System-Destructuring
775: (loop-desetq-temporary ())
776: #+Named-PROGs
777: (loop-prog-names ())
778: (loop-collect-cruft ())
779: (loop-collection-crocks ())
780: (keyword)
781: (tem)
782: (progvars))
783: ((null loop-source-code)
784: (and loop-conditionals
785: (loop-simple-error "Hanging conditional in loop macro"
786: (caadar loop-conditionals)))
787: (loop-optimize-duplicated-code-etc)
788: (loop-bind-block)
789: (setq progvars loop-collection-crocks)
790: #-System-Destructuring
791: (and loop-desetq-temporary (push loop-desetq-temporary progvars))
792: (setq tem `(prog #+Named-PROGs ,.loop-prog-names
793: ,progvars
794: #+Hairy-Collection
795: ,.(do ((l loop-collection-crocks (cddr l))
796: (v () (cons `(loop-collect-init
797: ,(cadr l) ,(car l))
798: v)))
799: ((null l) v))
800: ,.(nreverse loop-prologue)
801: ,.loop-before-loop
802: next-loop
803: ,.loop-body
804: ,.loop-after-body
805: (go next-loop)
806: ; Multics complr notices when end-loop is not gone
807: ; to. So we put in a dummy go. This does not generate
808: ; extra code, at least in the simple example i tried,
809: ; but it does keep it from complaining about unused
810: ; go tag.
811: #+Multics (go end-loop)
812: end-loop
813: ,.(nreverse loop-epilogue)
814: ,.(nreverse loop-after-epilogue)))
815: (do ((vars) (dcls) #-System-Destructuring (crocks))
816: ((null loop-variable-stack))
817: (setq vars (car loop-variable-stack)
818: loop-variable-stack (cdr loop-variable-stack)
819: dcls (car loop-declaration-stack)
820: loop-declaration-stack (cdr loop-declaration-stack)
821: tem (ncons tem))
822: #-System-Destructuring
823: (and (setq crocks (pop loop-desetq-stack))
824: (push (loop-make-desetq crocks) tem))
825: (and dcls (push (cons 'declare dcls) tem))
826: (cond ((do ((l vars (cdr l))) ((null l) ())
827: (and (not (atom (car l)))
828: (or (null (caar l)) (not (symbolp (caar l))))
829: (return 't)))
830: (setq tem `(let ,(nreverse vars) ,.tem)))
831: ('t (let ((lambda-vars ()) (lambda-vals ()))
832: (do ((l vars (cdr l)) (v)) ((null l))
833: (cond ((atom (setq v (car l)))
834: (push v lambda-vars)
835: (push () lambda-vals))
836: ('t (push (car v) lambda-vars)
837: (push (cadr v) lambda-vals))))
838: (setq tem `((lambda ,lambda-vars ,.tem)
839: ,.lambda-vals))))))
840: tem)
841: (if (symbolp (setq keyword (loop-pop-source)))
842: (if (setq tem (si:loop-tassoc keyword loop-keyword-alist))
843: (apply (cadr tem) (cddr tem))
844: (if (setq tem (si:loop-tassoc
845: keyword loop-iteration-keyword-alist))
846: (loop-hack-iteration tem)
847: (if (si:loop-tmember keyword '(and else))
848: ; Alternative is to ignore it, ie let it go around to the
849: ; next keyword...
850: (loop-simple-error
851: "secondary clause misplaced at top level in LOOP macro"
852: (list keyword (car loop-source-code)
853: (cadr loop-source-code)))
854: (loop-simple-error
855: "unknown keyword in LOOP macro" keyword))))
856: (loop-simple-error
857: "found where keyword expected in LOOP macro" keyword))))
858:
859:
860: (defun loop-bind-block ()
861: (cond ((not (null loop-variables))
862: (push loop-variables loop-variable-stack)
863: (push loop-declarations loop-declaration-stack)
864: (setq loop-variables () loop-declarations ())
865: #-System-Destructuring
866: (progn (push loop-desetq-crocks loop-desetq-stack)
867: (setq loop-desetq-crocks ())))))
868:
869:
870: ;Get FORM argument to a keyword. Read up to atom. PROGNify if necessary.
871: (defun loop-get-form ()
872: (do ((forms (ncons (loop-pop-source)) (cons (loop-pop-source) forms))
873: (nextform (car loop-source-code) (car loop-source-code)))
874: ((atom nextform)
875: (if (null (cdr forms)) (car forms)
876: (cons 'progn (nreverse forms))))))
877:
878:
879: ;Note that this function is not absolutely general. For instance, in Maclisp,
880: ; the functions < and > can only take 2 args, whereas greaterp and lessp
881: ; may take any number. Also, certain of the generic functions behave
882: ; differently from the type-specific ones in "degenerate" cases, like
883: ; QUOTIENT or DIFFERENCE of one arg.
884: ;And of course one always must be careful doing textual substitution.
885: (defun loop-typed-arith (substitutable-expression data-type)
886: #-(or Lispm Franz)
887: (if (setq data-type (car (si:loop-tmember (if (data-type? data-type)
888: (primitive-type data-type)
889: data-type)
890: '(fixnum flonum))))
891: (sublis (cond ((eq data-type 'fixnum)
892: #+For-NIL
893: '((plus . +&) (add1 . 1+&)
894: (difference . -&) (sub1 . 1-&)
895: (quotient . //&) (remainder . \&) (times . *&)
896: (zerop . 0p) (plusp . +p) (minusp . -p)
897: (greaterp . >&) (lessp . <&)
898: (min . min&) (max . max&))
899: #-For-NIL
900: '((plus . +) (add1 . 1+)
901: (difference . -) (sub1 . 1-)
902: (quotient . //) (remainder . \) (times . *)
903: (greaterp . >) (lessp . <)))
904: ('t #+For-NIL
905: '((plus . +$) (difference . -$)
906: (add1 . 1+$) (sub1 . 1-$)
907: (quotient . //$) (times . *$)
908: (greaterp . >$) (lessp . <$)
909: (max . max$) (min . min$))
910: #-For-NIL
911: '((plus . +$) (difference . -$)
912: (add1 . 1+$) (sub1 . 1-$)
913: (quotient . //$) (times . *$)
914: (greaterp . >) (lessp . <))))
915: substitutable-expression)
916: substitutable-expression)
917: #+Lispm
918: (progn data-type substitutable-expression)
919: #+Franz
920: (if (si:loop-tequal data-type 'fixnum)
921: (sublis '((add1 . 1+) (sub1 . 1-) (plus . +) (difference . -)
922: (times . *) (quotient . //) (remainder . \))
923: substitutable-expression)
924: substitutable-expression)
925: )
926:
927:
928: (defun loop-typed-init (data-type)
929: (cond ((data-type? data-type) (initial-value data-type))
930: ((setq data-type (car (si:loop-tmember
931: data-type '(fixnum flonum integer number
932: #+Loop-Small-Floatp
933: small-flonum))))
934: (cond ((eq data-type 'flonum) 0.0)
935: #+Loop-Small-Floatp
936: ((eq data-type 'small-flonum)
937: #.(and (loop-featurep Loop-Small-Floatp)
938: (small-float 0)))
939: ('t 0)))))
940:
941:
942: (defun loop-make-variable (name initialization dtype)
943: (cond ((null name)
944: (cond ((not (null initialization))
945: (push (list #+Lispm 'ignore
946: #+Multics (setq name (gensym))
947: #-(or Lispm Multics) ()
948: initialization)
949: loop-variables)
950: #+Multics (push `(progn ,name) loop-prologue))))
951: (#-Vector-Destructuring (atom name)
952: #+Vector-Destructuring (symbolp name)
953: (cond (loop-iteration-variablep
954: (if (memq name loop-iteration-variables)
955: (loop-simple-error
956: "Duplicated iteration variable somewhere in LOOP"
957: name)
958: (push name loop-iteration-variables)))
959: ((assq name loop-variables)
960: (loop-simple-error
961: "Duplicated var in LOOP bind block" name)))
962: #-Vector-Destructuring
963: (or (symbolp name)
964: (loop-simple-error "Bad variable somewhere in LOOP" name))
965: (loop-declare-variable name dtype)
966: ; We use ASSQ on this list to check for duplications (above),
967: ; so don't optimize out this list:
968: (push (list name (or initialization (loop-typed-init dtype)))
969: loop-variables))
970: (initialization
971: #+System-Destructuring
972: (progn (loop-declare-variable name dtype)
973: (push (list name initialization) loop-variables))
974: #-System-Destructuring
975: (cond (si:loop-use-system-destructuring?
976: (loop-declare-variable name dtype)
977: (push (list name initialization) loop-variables))
978: ('t (let ((newvar (gensym)))
979: (push (list newvar initialization) loop-variables)
980: ; LOOP-DESETQ-CROCKS gathered in reverse order.
981: (setq loop-desetq-crocks
982: (list* name newvar loop-desetq-crocks))
983: (loop-make-variable name () dtype)))))
984: ('t
985: #-Vector-Destructuring
986: (let ((tcar) (tcdr))
987: (if (atom dtype) (setq tcar (setq tcdr dtype))
988: (setq tcar (car dtype) tcdr (cdr dtype)))
989: (loop-make-variable (car name) () tcar)
990: (loop-make-variable (cdr name) () tcdr))
991: #+Vector-Destructuring
992: (cond ((object-that-cares-p name)
993: (let ((tcar) (tcdr))
994: (if (object-that-cares-p dtype)
995: (setq tcar (car dtype) tcdr (cdr dtype))
996: (setq tcar (setq tcdr dtype)))
997: (loop-make-variable (car name) () tcar)
998: (loop-make-variable (cdr name) () tcdr)))
999: ((vectorp name)
1000: (do ((i 0 (1+ i))
1001: (n (vector-length name))
1002: (dti 0 (1+ dti))
1003: (dtn (and (vectorp dtype) (vector-length dtype))))
1004: ((= i n))
1005: #+Run-in-Maclisp (declare (fixnum i n dti))
1006: (loop-make-variable
1007: (vref name i) ()
1008: (if (null dtn) dtype
1009: (and (< dti dtn) (vref dtype dti))))))
1010: ('t (loop-simple-error
1011: "bad variable somewhere in LOOP" name)))
1012: ))
1013: name)
1014:
1015:
1016: (defun loop-make-iteration-variable (name initialization dtype)
1017: (let ((loop-iteration-variablep 't))
1018: (loop-make-variable name initialization dtype)))
1019:
1020:
1021: (defun loop-declare-variable (name dtype)
1022: (cond ((or (null name) (null dtype)) ())
1023: ((symbolp name)
1024: (cond ((memq name loop-nodeclare))
1025: #+Multics
1026: ; local type dcls of specials lose. This doesn't work
1027: ; for locally-declared specials.
1028: ((get name 'special))
1029: ((data-type? dtype)
1030: (setq loop-declarations
1031: (append (variable-declarations dtype name)
1032: loop-declarations)))
1033: #+Meaningful-Type-Declarations
1034: ((si:loop-tmember dtype '(fixnum flonum))
1035: (push `(,dtype ,name) loop-declarations))))
1036: ((object-that-cares-p name)
1037: (cond ((object-that-cares-p dtype)
1038: (loop-declare-variable (car name) (car dtype))
1039: (loop-declare-variable (cdr name) (cdr dtype)))
1040: ('t (loop-declare-variable (car name) dtype)
1041: (loop-declare-variable (cdr name) dtype))))
1042: #+Vector-Destructuring
1043: ((vectorp name)
1044: (do ((i 0 (1+ i))
1045: (n (vector-length name))
1046: (dtn (and (vectorp dtype) (vector-length dtype)))
1047: (dti 0 (1+ dti)))
1048: ((= i n))
1049: #+Meaningful-Type-Declarations (declare (fixnum i n dti))
1050: (loop-declare-variable
1051: (vref name i)
1052: (if (null dtn) dtype (and (< dti dtn) (vref dtype dti))))))
1053: ('t (loop-simple-error "can't hack this"
1054: (list 'loop-declare-variable name dtype)))))
1055:
1056:
1057: #+For-PDP10
1058: (declare (special squid))
1059:
1060: (defun loop-constantp (form)
1061: (or (numberp form)
1062: #+For-NIL (or (null form) (vectorp form))
1063: #-For-NIL (memq form '(t ()))
1064: #-For-PDP10 (stringp form)
1065: (and (not (atom form))
1066: #-Run-on-PDP10 (eq (car form) 'quote)
1067: #+Run-on-PDP10 (or (eq (car form) 'quote)
1068: ; SQUID implies quoting.
1069: (and compiler-state (eq (car form) squid))))
1070: ))
1071:
1072: (defun loop-maybe-bind-form (form data-type?)
1073: ; Consider implementations which will not keep EQ quoted constants
1074: ; EQ after compilation & loading.
1075: ; Note FUNCTION is not hacked, multiple occurences might cause the
1076: ; compiler to break the function off multiple times!
1077: ; Hacking it probably isn't too important here anyway. The ones that
1078: ; matter are the ones that use it as a stepper (or whatever), which
1079: ; handle it specially.
1080: (if (loop-constantp form) form
1081: (loop-make-variable (gensym) form data-type?)))
1082:
1083:
1084: (defun loop-optional-type ()
1085: (let ((token (car loop-source-code)))
1086: (and (not (null token))
1087: (or (not (atom token))
1088: (data-type? token)
1089: (si:loop-tmember token '(fixnum flonum integer number notype
1090: #+Loop-Small-Floatp small-flonum)))
1091: (loop-pop-source))))
1092:
1093:
1094: ;Incorporates conditional if necessary
1095: (defun loop-make-conditionalization (form)
1096: (cond ((not (null loop-conditionals))
1097: (rplacd (last (car (last (car (last loop-conditionals)))))
1098: (ncons form))
1099: (cond ((si:loop-tequal (car loop-source-code) 'and)
1100: (loop-pop-source)
1101: ())
1102: ((si:loop-tequal (car loop-source-code) 'else)
1103: (loop-pop-source)
1104: ;; If we are already inside an else clause, close it off
1105: ;; and nest it inside the containing when clause
1106: (let ((innermost (car (last loop-conditionals))))
1107: (cond ((null (cddr innermost))) ;Now in a WHEN clause, OK
1108: ((null (cdr loop-conditionals))
1109: (loop-simple-error "More ELSEs than WHENs"
1110: (list 'else (car loop-source-code)
1111: (cadr loop-source-code))))
1112: ('t (setq loop-conditionals (cdr (nreverse loop-conditionals)))
1113: (rplacd (last (car (last (car loop-conditionals))))
1114: (ncons innermost))
1115: (setq loop-conditionals (nreverse loop-conditionals)))))
1116: ;; Start a new else clause
1117: (rplacd (last (car (last loop-conditionals)))
1118: (ncons (ncons ''t)))
1119: ())
1120: ('t ;Nest up the conditionals and output them
1121: (do ((prev (car loop-conditionals) (car l))
1122: (l (cdr loop-conditionals) (cdr l)))
1123: ((null l))
1124: (rplacd (last (car (last prev))) (ncons (car l))))
1125: (prog1 (car loop-conditionals)
1126: (setq loop-conditionals ())))))
1127: ('t form)))
1128:
1129: (defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form)))
1130: (cond ((not (null z))
1131: (cond (loop-emitted-body? (push z loop-body))
1132: ('t (push z loop-before-loop) (push z loop-after-body))))))
1133:
1134: (defun loop-emit-body (form)
1135: (setq loop-emitted-body? 't)
1136: (loop-pseudo-body form))
1137:
1138:
1139: #+Named-PROGs
1140: (defun loop-do-named ()
1141: (let ((name (loop-pop-source)))
1142: (or (and name (symbolp name))
1143: (loop-simple-error "Bad name for your loop construct" name))
1144: (and (cdr (setq loop-prog-names (cons name loop-prog-names)))
1145: (loop-simple-error "Too many names for your loop construct"
1146: loop-prog-names))))
1147:
1148: (defun loop-do-initially ()
1149: (push (loop-get-form) loop-prologue))
1150:
1151: (defun loop-nodeclare (&aux (varlist (loop-pop-source)))
1152: (or (and varlist (eq (typep varlist) 'list))
1153: (loop-simple-error "Bad varlist to nodeclare loop clause" varlist))
1154: (setq loop-nodeclare (append varlist loop-nodeclare)))
1155:
1156: (defun loop-do-finally ()
1157: (push (loop-get-form) loop-epilogue))
1158:
1159: (defun loop-do-do ()
1160: (loop-emit-body (loop-get-form)))
1161:
1162: (defun loop-do-return ()
1163: (loop-pseudo-body `(return ,(loop-get-form))))
1164:
1165:
1166: ;;;; List Collection
1167:
1168: ; The way we collect (list-collect) things is to bind two variables.
1169: ; One is the final result, and is accessible for value during the
1170: ; loop compuation. The second is the "tail". In implementations where
1171: ; we can do so, the tail var is initialized to a locative of the first,
1172: ; such that it can be updated with RPLACD. In other implementations,
1173: ; the update must be conditionalized (on whether or not the tail is NIL).
1174:
1175: ; For PDP10 Maclisp:
1176: ; The "value cell" of a special variable is a (pseudo) list cell, the CDR
1177: ; of which is the value. Hence the abovementioned tail variable gets
1178: ; initialized to this. (It happens to be the CDAR of the symbol.)
1179: ; For local variables in compiled code, the Maclisp compiler implements
1180: ; a (undocumented private) form of the
1181: ; "(setq tail (variable-location var))" construct; specifically, it
1182: ; is of the form (#.gofoo var tail). This construct must appear in
1183: ; the binding environment those variables are bound in, currently.
1184: ; Note that this hack only currently works for local variables, so loop
1185: ; has to check to see if the variable is special. It is anticipated,
1186: ; however, that the compiler will be able to do this all by itself
1187: ; at some point.
1188:
1189: #+For-PDP10
1190: (progn 'compile
1191: (cond ((status feature complr)
1192: (setq loop-specvar-hack ((lambda (obarray)
1193: (implode '(s p e c v a r s)))
1194: sobarray))
1195: (defun loop-collect-init-compiler (form)
1196: (cond ((memq compiler-state '(toplevel maklap))
1197: ; We are being "toplevel" macro expanded.
1198: ; We MUST expand into something which can be
1199: ; evaluated without loop, in the interpreter.
1200: `(setq ,(caddr form) (munkam (value-cell-location
1201: ',(cadr form)))))
1202: ((or specials
1203: (get (cadr form) 'special)
1204: (assq (cadr form) (symeval loop-specvar-hack)))
1205: `(setq ,(caddr form) (cdar ',(cadr form))))
1206: (t (cons gofoo (cdr form)))))
1207: (push '(loop-collect-init . loop-collect-init-compiler)
1208: macrolist)))
1209: (defun loop-collect-init fexpr (x)
1210: (set (cadr x) (cdar (car x)))))
1211:
1212: #+(and Hairy-Collection (not For-PDP10))
1213: (defmacro loop-collect-init (var1 var2)
1214: #+Lispm ;***** Remove kludgey fboundp when everyone up-to-date *****
1215: `(setq ,var2 ,(if (fboundp 'variable-location)
1216: `(variable-location ,var1)
1217: `(value-cell-location ',var1)))
1218: #-Lispm `(setq ,var2 (munkam (value-cell-location ',var1))))
1219:
1220:
1221: (defun loop-do-collect (type)
1222: (let ((var) (form) (tem) (tail) (dtype) (cruft) (rvar)
1223: (ctype (cond ((memq type '(max min)) 'maxmin)
1224: ((memq type '(nconc list append)) 'list)
1225: ((memq type '(count sum)) 'sum)
1226: ('t (loop-simple-error
1227: "unrecognized LOOP collecting keyword" type)))))
1228: (setq form (loop-get-form) dtype (loop-optional-type))
1229: (cond ((si:loop-tequal (car loop-source-code) 'into)
1230: (loop-pop-source)
1231: (setq rvar (setq var (loop-pop-source)))))
1232: ; CRUFT will be (varname ctype dtype var tail (optional tem))
1233: (cond ((setq cruft (assq var loop-collect-cruft))
1234: (cond ((not (eq ctype (car (setq cruft (cdr cruft)))))
1235: (loop-simple-error
1236: "incompatible LOOP collection types"
1237: (list ctype (car cruft))))
1238: ((and dtype (not (eq dtype (cadr cruft))))
1239: ;Conditional should be on data-type reality
1240: #+Run-in-Maclisp
1241: (loop-simple-error
1242: "Unequal data types in multiple collections"
1243: (list dtype (cadr cruft) (car cruft)))
1244: #-Run-in-Maclisp
1245: (ferror () "~A and ~A Unequal data types into ~A"
1246: dtype (cadr cruft) (car cruft))))
1247: (setq dtype (car (setq cruft (cdr cruft)))
1248: var (car (setq cruft (cdr cruft)))
1249: tail (car (setq cruft (cdr cruft)))
1250: tem (cadr cruft))
1251: (and (eq ctype 'maxmin)
1252: (not (atom form)) (null tem)
1253: (rplaca (cdr cruft) (setq tem (loop-make-variable
1254: (gensym) () dtype)))))
1255: ('t (and (null dtype)
1256: (setq dtype (cond ((eq type 'count) 'fixnum)
1257: ((memq type '(min max sum)) 'number))))
1258: (or var (push `(return ,(setq var (gensym)))
1259: loop-after-epilogue))
1260: (or (eq ctype 'list) (loop-make-iteration-variable var () dtype))
1261: (setq tail
1262: (cond ((eq ctype 'list)
1263: #-Hairy-Collection
1264: (setq tem (loop-make-variable (gensym) () ()))
1265: (car (setq loop-collection-crocks
1266: (list* (gensym) var
1267: loop-collection-crocks))))
1268: ((eq ctype 'maxmin)
1269: (or (atom form)
1270: (setq tem (loop-make-variable
1271: (gensym) () dtype)))
1272: (loop-make-variable (gensym) ''t ()))))
1273: (push (list rvar ctype dtype var tail tem)
1274: loop-collect-cruft)))
1275: (loop-emit-body
1276: (caseq type
1277: (count (setq tem `(setq ,var (,(loop-typed-arith 'add1 dtype)
1278: ,var)))
1279: (if (member form '(t 't)) tem `(and ,form ,tem)))
1280: (sum `(setq ,var (,(loop-typed-arith 'plus dtype) ,form ,var)))
1281: ((max min)
1282: (let ((forms ()) (arglist ()))
1283: ; TEM is temporary, properly typed.
1284: (and tem (setq forms `((setq ,tem ,form)) form tem))
1285: (setq arglist (list var form))
1286: (push (if (si:loop-tmember dtype '(fixnum flonum
1287: #+Loop-Small-Floatp
1288: small-flonum))
1289: ; no contagious arithmetic
1290: `(and (or ,tail
1291: (,(loop-typed-arith
1292: (if (eq type 'max) 'lessp 'greaterp)
1293: dtype)
1294: . ,arglist))
1295: (setq ,tail () . ,arglist))
1296: ; potentially contagious arithmetic -- must use
1297: ; MAX or MIN so that var will be contaminated
1298: `(setq ,var (cond (,tail (setq ,tail ()) ,form)
1299: ((,type . ,arglist)))))
1300: forms)
1301: (if (cdr forms) (cons 'progn (nreverse forms)) (car forms))))
1302: (t (caseq type
1303: (list (setq form (list 'list form)))
1304: (append (or (and (not (atom form)) (eq (car form) 'list))
1305: (setq form #+Lispm `(copylist* ,form)
1306: #-Lispm `(append ,form ())))))
1307: #+Hairy-Collection
1308: (let ((q `(rplacd ,tail ,form)))
1309: (cond ((and (not (atom form)) (eq (car form) 'list)
1310: (not (null (cdr form))))
1311: ; RPLACD of cdr-coded list:
1312: #+Lispm
1313: (rplaca (cddr q)
1314: (if (cddr form) `(list* ,@(cdr form) ())
1315: `(ncons ,(cadr form))))
1316: `(setq ,tail ,(loop-cdrify (cdr form) q)))
1317: ('t `(and (cdr ,q)
1318: (setq ,tail (last (cdr ,tail)))))))
1319: #-Hairy-Collection
1320: (let ((q `(cond (,tail (cdr (rplacd ,tail ,tem)))
1321: ((setq ,var ,tem)))))
1322: (if (and (not (atom form)) (eq (car form) 'list) (cdr form))
1323: `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q))
1324: `(and (setq ,tem ,form) (setq ,tail (last ,q))))))))))
1325:
1326:
1327: (defun loop-cdrify (arglist form)
1328: (do ((size (length arglist) (- size 4)))
1329: ((< size 4)
1330: (if (zerop size) form
1331: (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) ('t 'cdddr))
1332: form)))
1333: #+Meaningful-Type-Declarations (declare (fixnum size))
1334: (setq form (list 'cddddr form))))
1335:
1336:
1337: (defun loop-do-while (cond kwd &aux (form (loop-get-form)))
1338: (and loop-conditionals (loop-simple-error
1339: "not allowed inside LOOP conditional"
1340: (list kwd form)))
1341: (loop-pseudo-body `(,cond ,form (go end-loop))))
1342:
1343:
1344: (defun loop-do-when (negate?)
1345: (let ((form (loop-get-form)) (cond))
1346: (cond ((si:loop-tequal (cadr loop-source-code) 'it)
1347: ;WHEN foo RETURN IT and the like
1348: (setq cond `(setq ,(loop-when-it-variable) ,form))
1349: (setq loop-source-code ;Plug in variable for IT
1350: (list* (car loop-source-code)
1351: loop-when-it-variable
1352: (cddr loop-source-code))))
1353: ('t (setq cond form)))
1354: (and negate? (setq cond `(not ,cond)))
1355: (setq loop-conditionals (nconc loop-conditionals `((cond (,cond)))))))
1356:
1357: (defun loop-do-with ()
1358: (do ((var) (equals) (val) (dtype)) (())
1359: (setq var (loop-pop-source) equals (car loop-source-code))
1360: (cond ((si:loop-tequal equals '=)
1361: (loop-pop-source)
1362: (setq val (loop-get-form) dtype ()))
1363: ((or (si:loop-tequal equals 'and)
1364: (si:loop-tassoc equals loop-keyword-alist)
1365: (si:loop-tassoc equals loop-iteration-keyword-alist))
1366: (setq val () dtype ()))
1367: ('t (setq dtype (loop-pop-source) equals (car loop-source-code))
1368: (cond ((si:loop-tequal equals '=)
1369: (loop-pop-source)
1370: (setq val (loop-get-form)))
1371: ((and (not (null loop-source-code))
1372: (not (si:loop-tassoc equals loop-keyword-alist))
1373: (not (si:loop-tassoc
1374: equals loop-iteration-keyword-alist))
1375: (not (si:loop-tequal equals 'and)))
1376: (loop-simple-error "Garbage where = expected" equals))
1377: ('t (setq val ())))))
1378: (loop-make-variable var val dtype)
1379: (if (not (si:loop-tequal (car loop-source-code) 'and)) (return ())
1380: (loop-pop-source)))
1381: (loop-bind-block))
1382:
1383: (defun loop-do-always (pred)
1384: (let ((form (loop-get-form)))
1385: (loop-emit-body `(,pred ,form (return ())))
1386: (push '(return 't) loop-after-epilogue)))
1387:
1388: ;THEREIS expression
1389: ;If expression evaluates non-nil, return that value.
1390: (defun loop-do-thereis ()
1391: (loop-emit-body `(and (setq ,(loop-when-it-variable) ,(loop-get-form))
1392: (return ,loop-when-it-variable))))
1393:
1394:
1395: ;;;; Hacks
1396:
1397: #+Meaningful-Type-Declarations
1398: (declare (fixnum (loop-simplep-1 notype)))
1399:
1400: (defun si:loop-simplep (expr)
1401: (if (null expr) 0
1402: (*catch 'si:loop-simplep
1403: (let ((ans (si:loop-simplep-1 expr)))
1404: #+Meaningful-Type-Declarations (declare (fixnum ans))
1405: (and (< ans 20.) ans)))))
1406:
1407: (defvar si:loop-simplep
1408: (append '(> < greaterp lessp plusp minusp typep zerop
1409: plus difference + - add1 sub1 1+ 1-
1410: +$ -$ 1+$ 1-$ boole rot ash ldb equal atom
1411: setq prog1 prog2 and or =)
1412: #+(or Lispm NIL) '(aref ar-1 ar-2 ar-3)
1413: #+Lispm '#.(and (loop-featurep Lispm)
1414: (mapcar 'ascii '(#/ #/ #/)))
1415: #+For-NIL '(vref vector-length 1+& 1-& +& -& +p -p 0p *& //& \&
1416: si:xref char string-length)
1417: ))
1418:
1419: (defun si:loop-simplep-1 (x)
1420: (let ((z 0))
1421: #+Meaningful-Type-Declarations (declare (fixnum z))
1422: (cond ((loop-constantp x) 0)
1423: ((atom x) 1)
1424: ((eq (car x) 'cond)
1425: (do ((cl (cdr x) (cdr cl))) ((null cl))
1426: (do ((f (car cl) (cdr f))) ((null f))
1427: (setq z (+ (si:loop-simplep-1 (car f)) z 1))))
1428: z)
1429: ((symbolp (car x))
1430: (let ((fn (car x)) (tem ()))
1431: (cond ((setq tem (get fn 'si:loop-simplep))
1432: (if (fixp tem) (setq z tem)
1433: (setq z (funcall tem x) x ())))
1434: ((memq fn '(null not eq go return progn)))
1435: (#+Run-on-PDP10
1436: (or (not (minusp (+internal-carcdrp fn)))
1437: (eq fn 'cxr))
1438: #-Run-on-PDP10 (memq fn '(car cdr))
1439: (setq z 1))
1440: #-Run-on-PDP10
1441: ((memq fn '(caar cadr cdar cddr)) (setq z 2))
1442: #-Run-on-PDP10
1443: ((memq fn '(caaar caadr cadar caddr
1444: cdaar cdadr cddar cdddr))
1445: (setq z 3))
1446: #-Run-on-PDP10
1447: ((memq fn '(caaaar caaadr caadar caaddr
1448: cadaar cadadr caddar cadddr
1449: cdaaar cdaadr cdadar cdaddr
1450: cddaar cddadr cdddar cddddr))
1451: (setq z 4))
1452: ((memq fn si:loop-simplep)
1453: (setq z 2))
1454: (#+(or Lispm For-PDP10 For-NIL)
1455: (not (eq (setq tem (macroexpand-1 x)) x))
1456: #+Franz (not (eq (setq tem (macroexpand x)) x))
1457: #+Multics
1458: (setq tem (get (car x) 'macro))
1459: #+Multics (setq tem (funcall tem x))
1460: (setq z (si:loop-simplep-1 tem) x ()))
1461: ('t (*throw 'si:loop-simplep ())))
1462: (do ((l (cdr x) (cdr l))) ((null l))
1463: (setq z (+ (si:loop-simplep-1 (car l)) 1 z)))
1464: z))
1465: ('t (*throw 'si:loop-simplep ())))))
1466:
1467:
1468: ;;;; The iteration driver
1469: (defun loop-hack-iteration (entry)
1470: (do ((last-entry entry)
1471: (source loop-source-code loop-source-code)
1472: (pre-step-tests ())
1473: (steps ())
1474: (post-step-tests ())
1475: (pseudo-steps ())
1476: (pre-loop-pre-step-tests ())
1477: (pre-loop-steps ())
1478: (pre-loop-post-step-tests ())
1479: (pre-loop-pseudo-steps ())
1480: (tem) (data) (foo) (bar))
1481: (())
1482: ; Note we collect endtests in reverse order, but steps in correct
1483: ; order. LOOP-END-TESTIFY does the nreverse for us.
1484: (setq tem (setq data (apply (cadr entry) (cddr entry))))
1485: (and (car tem) (push (car tem) pre-step-tests))
1486: (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
1487: (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
1488: (setq pseudo-steps
1489: (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
1490: (setq tem (cdr tem))
1491: (and (or loop-conditionals loop-emitted-body?)
1492: (or tem pre-step-tests post-step-tests pseudo-steps)
1493: (let ((cruft (list (car entry) (car source)
1494: (cadr source) (caddr source))))
1495: (if loop-emitted-body?
1496: (loop-simple-error
1497: "Iteration is not allowed to follow body code" cruft)
1498: (loop-simple-error
1499: "Iteration starting inside of conditional in LOOP"
1500: cruft))))
1501: (or tem (setq tem data))
1502: (and (car tem) (push (car tem) pre-loop-pre-step-tests))
1503: (setq pre-loop-steps
1504: (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
1505: (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
1506: (setq pre-loop-pseudo-steps
1507: (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
1508: (cond ((or (not (si:loop-tequal (car loop-source-code) 'and))
1509: (and loop-conditionals
1510: (not (si:loop-tassoc (cadr loop-source-code)
1511: loop-iteration-keyword-alist))))
1512: (setq foo (list (loop-end-testify pre-loop-pre-step-tests)
1513: (loop-make-psetq pre-loop-steps)
1514: (loop-end-testify pre-loop-post-step-tests)
1515: (loop-make-setq pre-loop-pseudo-steps))
1516: bar (list (loop-end-testify pre-step-tests)
1517: (loop-make-psetq steps)
1518: (loop-end-testify post-step-tests)
1519: (loop-make-setq pseudo-steps)))
1520: (cond ((not loop-conditionals)
1521: (setq loop-before-loop (nreconc foo loop-before-loop)
1522: loop-after-body (nreconc bar loop-after-body)))
1523: ('t ((lambda (loop-conditionals)
1524: (push (loop-make-conditionalization
1525: (cons 'progn (delq () foo)))
1526: loop-before-loop))
1527: (mapcar '(lambda (x) ;Copy parts that will get rplacd'ed
1528: (cons (car x)
1529: (mapcar '(lambda (x) (loop-copylist* x)) (cdr x))))
1530: loop-conditionals))
1531: (push (loop-make-conditionalization
1532: (cons 'progn (delq () bar)))
1533: loop-after-body)))
1534: (loop-bind-block)
1535: (return ())))
1536: (loop-pop-source) ; flush the "AND"
1537: (setq entry (cond ((setq tem (si:loop-tassoc
1538: (car loop-source-code)
1539: loop-iteration-keyword-alist))
1540: (loop-pop-source)
1541: (setq last-entry tem))
1542: ('t last-entry)))))
1543:
1544:
1545: ;FOR variable keyword ..args..
1546: (defun loop-do-for ()
1547: (let ((var (loop-pop-source))
1548: (data-type? (loop-optional-type))
1549: (keyword (loop-pop-source))
1550: (first-arg (loop-get-form))
1551: (tem ()))
1552: (or (setq tem (si:loop-tassoc keyword loop-for-keyword-alist))
1553: (loop-simple-error
1554: "Unknown keyword in FOR or AS clause in LOOP"
1555: (list 'for var keyword)))
1556: (lexpr-funcall (cadr tem) var first-arg data-type? (cddr tem))))
1557:
1558:
1559: (defun loop-do-repeat ()
1560: (let ((var (loop-make-variable (gensym) (loop-get-form) 'fixnum)))
1561: `((not (,(loop-typed-arith 'plusp 'fixnum) ,var))
1562: () ()
1563: (,var (,(loop-typed-arith 'sub1 'fixnum) ,var)))))
1564:
1565:
1566: ; Kludge the First
1567: (defun loop-when-it-variable ()
1568: (or loop-when-it-variable
1569: (setq loop-when-it-variable
1570: (loop-make-variable (gensym) () ()))))
1571:
1572:
1573:
1574: (defun loop-for-equals (var val data-type?)
1575: (cond ((si:loop-tequal (car loop-source-code) 'then)
1576: ;FOR var = first THEN next
1577: (loop-pop-source)
1578: (loop-make-iteration-variable var val data-type?)
1579: `(() (,var ,(loop-get-form)) () ()
1580: () () () ()))
1581: ('t (loop-make-iteration-variable var () data-type?)
1582: (let ((varval (list var val)))
1583: (cond (loop-emitted-body?
1584: (loop-emit-body (loop-make-setq varval))
1585: '(() () () ()))
1586: (`(() ,varval () ())))))))
1587:
1588: (defun loop-for-first (var val data-type?)
1589: (or (si:loop-tequal (car loop-source-code) 'then)
1590: (loop-simple-error "found where THEN expected in FOR ... FIRST"
1591: (car loop-source-code)))
1592: (loop-pop-source)
1593: (loop-make-iteration-variable var () data-type?)
1594: `(() (,var ,(loop-get-form)) () () () (,var ,val) () ()))
1595:
1596:
1597: (defun loop-list-stepper (var val data-type? fn)
1598: (let ((stepper (cond ((si:loop-tequal (car loop-source-code) 'by)
1599: (loop-pop-source) (loop-get-form))
1600: ('t '(function cdr))))
1601: (var1 ()) (stepvar ()) (step ()) (et ()) (pseudo ()))
1602: (setq step (if (or (atom stepper)
1603: (not (memq (car stepper) '(quote function))))
1604: `(funcall ,(setq stepvar (gensym)))
1605: (list (cadr stepper))))
1606: (cond ((and (atom var)
1607: ;; (eq (car step) 'cdr)
1608: (not fn))
1609: (setq var1 (loop-make-iteration-variable var val data-type?)))
1610: ('t (loop-make-iteration-variable var () data-type?)
1611: (setq var1 (loop-make-variable (gensym) val ()))
1612: (setq pseudo (list var (if fn (list fn var1) var1)))))
1613: (rplacd (last step) (list var1))
1614: (and stepvar (loop-make-variable stepvar stepper ()))
1615: (setq stepper (list var1 step) et `(null ,var1))
1616: (if (not pseudo) `(() ,stepper ,et () () () ,et ())
1617: (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper)
1618: `((null (setq . ,stepper)) () () ,pseudo ,et () () ,pseudo)))))
1619:
1620:
1621: (defun loop-for-arithmetic (var val data-type? kwd)
1622: ; Args to loop-sequencer:
1623: ; indexv indexv-type variable? vtype? sequencev? sequence-type
1624: ; stephack? default-top? crap prep-phrases
1625: (si:loop-sequencer
1626: var (or data-type? 'fixnum) () () () () () () `(for ,var ,kwd ,val)
1627: (cons (list kwd val)
1628: (loop-gather-preps
1629: '(from upfrom downfrom to upto downto above below by)
1630: ()))))
1631:
1632:
1633: (defun si:loop-named-variable (name)
1634: (let ((tem (si:loop-tassoc name loop-named-variables)))
1635: (cond ((null tem) (gensym))
1636: ('t (setq loop-named-variables (delq tem loop-named-variables))
1637: (cdr tem)))))
1638:
1639: #+Run-in-Maclisp ;Gross me out
1640: (and (status feature #+Multics Compiler #-Multics complr)
1641: (*expr si:loop-named-variable))
1642:
1643:
1644: ; Note: path functions are allowed to use loop-make-variable, hack
1645: ; the prologue, etc.
1646: (defun loop-for-being (var val data-type?)
1647: ; FOR var BEING something ... - var = VAR, something = VAL.
1648: ; If what passes syntactically for a pathname isn't, then
1649: ; we trap to the DEFAULT-LOOP-PATH path; the expression which looked like
1650: ; a path is given as an argument to the IN preposition. Thus,
1651: ; by default, FOR var BEING EACH expr OF expr-2
1652: ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2.
1653: (let ((tem) (inclusive?) (ipps) (each?) (attachment))
1654: (if (or (si:loop-tequal val 'each) (si:loop-tequal val 'the))
1655: (setq each? 't val (car loop-source-code))
1656: (push val loop-source-code))
1657: (cond ((and (setq tem (si:loop-tassoc val loop-path-keyword-alist))
1658: (or each? (not (si:loop-tequal (cadr loop-source-code)
1659: 'and))))
1660: ;; FOR var BEING {each} path {prep expr}..., but NOT
1661: ;; FOR var BEING var-which-looks-like-path AND {ITS} ...
1662: (loop-pop-source))
1663: ('t (setq val (loop-get-form))
1664: (cond ((si:loop-tequal (car loop-source-code) 'and)
1665: ;; FOR var BEING value AND ITS path-or-ar
1666: (or (null each?)
1667: (loop-simple-error
1668: "Malformed BEING EACH clause in LOOP" var))
1669: (setq ipps `((of ,val)) inclusive? 't)
1670: (loop-pop-source)
1671: (or (si:loop-tmember (setq tem (loop-pop-source))
1672: '(its his her their each))
1673: (loop-simple-error
1674: "found where ITS or EACH expected in LOOP path"
1675: tem))
1676: (if (setq tem (si:loop-tassoc
1677: (car loop-source-code)
1678: loop-path-keyword-alist))
1679: (loop-pop-source)
1680: (push (setq attachment `(in ,(loop-get-form)))
1681: ipps)))
1682: ((not (setq tem (si:loop-tassoc
1683: (car loop-source-code)
1684: loop-path-keyword-alist)))
1685: ; FOR var BEING {each} a-r ...
1686: (setq ipps (list (setq attachment (list 'in val)))))
1687: ('t ; FOR var BEING {each} pathname ...
1688: ; Here, VAL should be just PATHNAME.
1689: (loop-pop-source)))))
1690: (cond ((not (null tem)))
1691: ((not (setq tem (si:loop-tassoc 'default-loop-path
1692: loop-path-keyword-alist)))
1693: (loop-simple-error "Undefined LOOP iteration path"
1694: (cadr attachment))))
1695: (setq tem (funcall (cadr tem) (car tem) var data-type?
1696: (nreconc ipps (loop-gather-preps (caddr tem) 't))
1697: inclusive? (caddr tem) (cdddr tem)))
1698: (and loop-named-variables
1699: (loop-simple-error "unused USING variables" loop-named-variables))
1700: ; For error continuability (if there is any):
1701: (setq loop-named-variables ())
1702: ;; TEM is now (bindings prologue-forms . stuff-to-pass-back)
1703: (do ((l (car tem) (cdr l)) (x)) ((null l))
1704: (if (atom (setq x (car l)))
1705: (loop-make-iteration-variable x () ())
1706: (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
1707: (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue))
1708: (cddr tem)))
1709:
1710:
1711: (defun loop-gather-preps (preps-allowed crockp)
1712: (do ((token (car loop-source-code) (car loop-source-code)) (preps ()))
1713: (())
1714: (cond ((si:loop-tmember token preps-allowed)
1715: (push (list (loop-pop-source) (loop-get-form)) preps))
1716: ((si:loop-tequal token 'using)
1717: (loop-pop-source)
1718: (or crockp (loop-simple-error
1719: "USING used in illegal context"
1720: (list 'using (car loop-source-code))))
1721: (do ((z (car loop-source-code) (car loop-source-code)) (tem))
1722: ((atom z))
1723: (and (or (atom (cdr z))
1724: (not (null (cddr z)))
1725: (not (symbolp (car z)))
1726: (and (cadr z) (not (symbolp (cadr z)))))
1727: (loop-simple-error
1728: "bad variable pair in path USING phrase" z))
1729: (cond ((not (null (cadr z)))
1730: (and (setq tem (si:loop-tassoc
1731: (car z) loop-named-variables))
1732: (loop-simple-error
1733: "Duplicated var substitition in USING phrase"
1734: (list tem z)))
1735: (push (cons (car z) (cadr z)) loop-named-variables)))
1736: (loop-pop-source)))
1737: ('t (return (nreverse preps))))))
1738:
1739: (defun loop-add-path (name data)
1740: (setq loop-path-keyword-alist
1741: (cons (cons name data)
1742: ; Don't change this to use DELASSQ in PDP10, the lsubr
1743: ; calling sequence makes that lose.
1744: (delq (si:loop-tassoc name loop-path-keyword-alist)
1745: loop-path-keyword-alist)))
1746: ())
1747:
1748: #+Run-on-PDP10
1749: (declare ; Suck my obarray...
1750: (own-symbol define-loop-path define-loop-sequence-path))
1751:
1752: (defmacro define-loop-path (names &rest cruft)
1753: (setq names (if (atom names) (list names) names))
1754: #-For-Maclisp
1755: (let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft))
1756: names)))
1757: `(eval-when (eval load compile)
1758: #+For-NIL (flush-macromemos 'loop ())
1759: ,@forms))
1760: #+For-Maclisp
1761: (subst (do ((l)) ((null names) l)
1762: (setq l (cons `(setq loop-path-keyword-alist
1763: (cons '(,(car names) . ,cruft)
1764: (delq (assq ',(car names)
1765: loop-path-keyword-alist)
1766: loop-path-keyword-alist)))
1767: l)
1768: names (cdr names)))
1769: 'progn
1770: '(eval-when (eval load compile)
1771: #-For-PDP10 (or (boundp 'loop-path-keyword-alist)
1772: (setq loop-path-keyword-alist ()))
1773: #+For-PDP10 (and (or (boundp 'loop-path-keyword-alist)
1774: (setq loop-path-keyword-alist ()))
1775: (flush-macromemos 'loop ()))
1776: . progn)))
1777:
1778:
1779: (defun si:loop-sequencer (indexv indexv-type
1780: variable? vtype?
1781: sequencev? sequence-type?
1782: stephack? default-top?
1783: crap prep-phrases)
1784: (let ((endform) (sequencep) (test)
1785: (step ; Gross me out!
1786: (add1 (or (loop-typed-init indexv-type) 0)))
1787: (dir) (inclusive-iteration?) (start-given?) (limit-given?))
1788: (and variable? (loop-make-iteration-variable variable? () vtype?))
1789: (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
1790: (setq prep (caar l) form (cadar l))
1791: (cond ((si:loop-tmember prep '(of in))
1792: (and sequencep (loop-simple-error
1793: "Sequence duplicated in LOOP path"
1794: (list variable? (car l))))
1795: (setq sequencep 't)
1796: (loop-make-variable sequencev? form sequence-type?))
1797: ((si:loop-tmember prep '(from downfrom upfrom))
1798: (and start-given?
1799: (loop-simple-error
1800: "Iteration start redundantly specified in LOOP sequencing"
1801: (append crap l)))
1802: (setq start-given? 't)
1803: (cond ((si:loop-tequal prep 'downfrom) (setq dir 'down))
1804: ((si:loop-tequal prep 'upfrom) (setq dir 'up)))
1805: (loop-make-iteration-variable indexv form indexv-type))
1806: ((cond ((si:loop-tequal prep 'upto)
1807: (setq inclusive-iteration? (setq dir 'up)))
1808: ((si:loop-tequal prep 'to)
1809: (setq inclusive-iteration? 't))
1810: ((si:loop-tequal prep 'downto)
1811: (setq inclusive-iteration? (setq dir 'down)))
1812: ((si:loop-tequal prep 'above) (setq dir 'down))
1813: ((si:loop-tequal prep 'below) (setq dir 'up)))
1814: (and limit-given?
1815: (loop-simple-error
1816: "Endtest redundantly specified in LOOP sequencing path"
1817: (append crap l)))
1818: (setq limit-given? 't)
1819: (setq endform (loop-maybe-bind-form form indexv-type)))
1820: ((si:loop-tequal prep 'by)
1821: (setq step (if (loop-constantp form) form
1822: (loop-make-variable (gensym) form 'fixnum))))
1823: ('t ; This is a fatal internal error...
1824: (loop-simple-error "Illegal prep in sequence path"
1825: (append crap l))))
1826: (and odir dir (not (eq dir odir))
1827: (loop-simple-error
1828: "Conflicting stepping directions in LOOP sequencing path"
1829: (append crap l)))
1830: (setq odir dir))
1831: (and sequencev? (not sequencep)
1832: (loop-simple-error "Missing OF phrase in sequence path" crap))
1833: ; Now fill in the defaults.
1834: (setq step (list indexv step))
1835: (cond ((memq dir '(() up))
1836: (or start-given?
1837: (loop-make-iteration-variable indexv 0 indexv-type))
1838: (and (or limit-given?
1839: (cond (default-top?
1840: (loop-make-variable
1841: (setq endform (gensym)) () indexv-type)
1842: (push `(setq ,endform ,default-top?)
1843: loop-prologue))))
1844: (setq test (if inclusive-iteration? '(greaterp . args)
1845: '(not (lessp . args)))))
1846: (push 'plus step))
1847: ('t (cond ((not start-given?)
1848: (or default-top?
1849: (loop-simple-error
1850: "Don't know where to start stepping"
1851: (append crap prep-phrases)))
1852: (loop-make-iteration-variable indexv 0 indexv-type)
1853: (push `(setq ,indexv
1854: (,(loop-typed-arith 'sub1 indexv-type)
1855: ,default-top?))
1856: loop-prologue)))
1857: (cond ((and default-top? (not endform))
1858: (setq endform (loop-typed-init indexv-type)
1859: inclusive-iteration? 't)))
1860: (and (not (null endform))
1861: (setq test (if inclusive-iteration? '(lessp . args)
1862: '(not (greaterp . args)))))
1863: (push 'difference step)))
1864: (and (member (caddr step)
1865: #+Loop-Small-Floatp
1866: '(1 1.0 #.(and (loop-featurep Loop-Small-Floatp)
1867: (small-float 1)))
1868: #-Loop-Small-Floatp '(1 1.0))
1869: (rplacd (cdr (rplaca step (if (eq (car step) 'plus) 'add1 'sub1)))
1870: ()))
1871: (rplaca step (loop-typed-arith (car step) indexv-type))
1872: (setq step (list indexv step))
1873: (setq test (loop-typed-arith test indexv-type))
1874: (setq test (subst (list indexv endform) 'args test))
1875: (and stephack? (setq stephack? `(,variable? ,stephack?)))
1876: `(() ,step ,test ,stephack?
1877: () () ,test ,stephack?)))
1878:
1879:
1880: ; Although this function is no longer documented, the "SI:" is needed
1881: ; because compiled files may reference it that way (via
1882: ; DEFINE-LOOP-SEQUENCE-PATH).
1883: (defun si:loop-sequence-elements-path (path variable data-type
1884: prep-phrases inclusive?
1885: allowed-preps data)
1886: allowed-preps ; unused
1887: (let ((indexv (si:loop-named-variable 'index))
1888: (sequencev (si:loop-named-variable 'sequence))
1889: (fetchfun ()) (sizefun ()) (type ()) (default-var-type ())
1890: (crap `(for ,variable being the ,path)))
1891: (cond ((not (null inclusive?))
1892: (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path))
1893: (loop-simple-error "Can't step sequence inclusively" crap)))
1894: (setq fetchfun (car data)
1895: sizefun (car (setq data (cdr data)))
1896: type (car (setq data (cdr data)))
1897: default-var-type (cadr data))
1898: (list* () () ; dummy bindings and prologue
1899: (si:loop-sequencer
1900: indexv 'fixnum
1901: variable (or data-type default-var-type)
1902: sequencev type
1903: `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev)
1904: crap prep-phrases))))
1905:
1906:
1907: #+Run-on-PDP10
1908: (defun (define-loop-sequence-path macro) (x)
1909: `(define-loop-path ,(cadr x) si:loop-sequence-elements-path
1910: (of in from downfrom to downto below above by)
1911: . ,(cddr x)))
1912:
1913: #-Run-on-PDP10
1914: (defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun
1915: &optional sequence-type element-type)
1916: `(define-loop-path ,path-name-or-names
1917: si:loop-sequence-elements-path
1918: (of in from downfrom to downto below above by)
1919: ,fetchfun ,sizefun ,sequence-type ,element-type))
1920:
1921:
1922: ;;;; NIL interned-symbols path
1923:
1924: #+For-NIL
1925: (progn 'compile
1926: (defun loop-interned-symbols-path (path variable data-type prep-phrases
1927: inclusive? allowed-preps data
1928: &aux statev1 statev2 statev3
1929: (localp (car data)))
1930: allowed-preps ; unused
1931: (and inclusive? (loop-simple-error
1932: "INTERNED-SYMBOLS path doesn't work inclusively"
1933: variable))
1934: (and (not (null prep-phrases))
1935: (or (cdr prep-phrases)
1936: (not (si:loop-tmember (caar prep-phrases) '(in of))))
1937: (ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A"
1938: path variable prep-phrases))
1939: (loop-make-variable variable () data-type)
1940: (loop-make-variable
1941: (setq statev1 (gensym))
1942: `(loop-find-package
1943: ,@(and prep-phrases `(,(cadar prep-phrases))))
1944: ())
1945: (loop-make-variable (setq statev2 (gensym)) () ())
1946: (loop-make-variable (setq statev3 (gensym)) () ())
1947: (push `(multiple-value (,statev1 ,statev2 ,statev3)
1948: (loop-initialize-mapatoms-state ,statev1 ',localp))
1949: loop-prologue)
1950: `(() () (multiple-value (() ,statev1 ,statev2 ,statev3)
1951: (,(if localp 'loop-test-and-step-mapatoms-local
1952: 'loop-test-and-step-mapatoms)
1953: ,statev1 ,statev2 ,statev3))
1954: (,variable (loop-get-mapatoms-symbol ,statev1 ,statev2 ,statev3)) () ()))
1955:
1956: (defun loop-find-package (&optional (pkg () pkgp))
1957: #+Run-in-Maclisp
1958: (if pkgp pkg obarray)
1959: #-Run-in-Maclisp
1960: (if pkgp (pkg-find-package pkg) package))
1961:
1962: (defun loop-find-package-translate (form)
1963: ; Note that we can only be compiling for nil-nil, so we only need
1964: ; to consider that. The run-in-maclisp conditionals in the functions
1965: ; are for the benefit of running interpreted code.
1966: (values (if (null (cdr form)) 'package `(pkg-find-package ,(cadr form))) 't))
1967:
1968: (putprop 'loop-find-package
1969: '(loop-find-package-translate)
1970: 'source-trans)
1971:
1972: #-Run-in-Maclisp
1973: (defun loop-initialize-mapatoms-state (pkg localp)
1974: (let* ((symtab (si:package-symbol-table pkg))
1975: (len (vector-length symtab)))
1976: (values pkg len (if localp symtab (cons (ncons pkg) ())))))
1977:
1978: #+Run-in-Maclisp
1979: (defun loop-initialize-mapatoms-state (ob ())
1980: (values ob (ncons nil) 511.))
1981:
1982: #-Run-in-Maclisp
1983: (defun loop-test-and-step-mapatoms (pkg index location &aux val)
1984: (prog (symtab)
1985: (setq symtab (si:package-symbol-table pkg))
1986: lp (cond ((-p (setq index (1-& index)))
1987: ;(do ((l (si:package-super-packages pkg) (cdr l)))
1988: ; ((null l) (cdr location))
1989: ; (or (memq (car l) (car location))
1990: ; (memq (car l) (cdr location))
1991: ; (rplacd location (cons (car l) (cdr location)))))
1992: (let ((p (si:package-super-package pkg)))
1993: (or (memq p (car location))
1994: (memq p (cdr location))
1995: (rplacd location (cons p (cdr location)))))
1996: (or (cdr location) (return (setq val 't)))
1997: (rplacd location
1998: (prog1 (cddr location)
1999: (rplaca location
2000: (rplacd (cdr location)
2001: (car location)))))
2002: (setq pkg (caar location))
2003: (setq symtab (si:package-symbol-table pkg))
2004: (setq index (vector-length symtab))
2005: (go lp))
2006: ((symbolp (vref symtab index)) (return ()))
2007: ('t (go lp))))
2008: (values val pkg index location))
2009:
2010: #+Run-in-Maclisp
2011: (defun loop-test-and-step-mapatoms (ob list index)
2012: (loop-test-and-step-mapatoms-local ob list index))
2013:
2014: #-Run-in-Maclisp
2015: (defun loop-test-and-step-mapatoms-local (pkg index symtab &aux val)
2016: (prog ()
2017: lp (cond ((-p (setq index (1-& index))) (return (setq val 't)))
2018: ((symbolp (vref symtab index)) (return ()))
2019: ('t (go lp))))
2020: (values val pkg index symtab))
2021:
2022: #+Run-in-Maclisp
2023: (defun loop-test-and-step-mapatoms-local (ob list index &aux val)
2024: (declare (fixnum index))
2025: (prog ()
2026: lp (cond ((not (null (cdr list)))
2027: (rplaca list (cadr list))
2028: (rplacd list (cddr list))
2029: (return ()))
2030: ((minusp (setq index (1- index))) (return (setq val 't)))
2031: ('t ; If this is going to run in multics maclisp also the
2032: ; arraycall should be hacked to have type `obarray'.
2033: (rplacd list (arraycall t ob index))
2034: (go lp))))
2035: (values val ob list index))
2036:
2037: #-Run-in-Maclisp
2038: (defun loop-get-mapatoms-symbol (pkg index something-or-other)
2039: ;Note there is a potential bug/timing screw in here. We should be
2040: ; looking in the symbol-table saved initially, not the current one.
2041: ; There just isn't enough state saved (sigh).
2042: (declare (ignore something-or-other))
2043: (vref (si:package-symbol-table pkg) index))
2044:
2045: #+Run-in-Maclisp
2046: (defun loop-get-mapatoms-symbol (ob list index)
2047: (declare (ignore ob index))
2048: (car list))
2049:
2050: (and #+Run-in-Maclisp (status feature complr)
2051: (*expr loop-get-mapatoms-symbol
2052: loop-initialize-mapatoms-state
2053: loop-test-and-step-mapatoms
2054: loop-test-and-step-mapatoms-local))
2055: )
2056:
2057:
2058: ;;;; Maclisp interned-symbols path
2059:
2060: #+For-Maclisp
2061: (defun loop-interned-symbols-path (path variable data-type prep-phrases
2062: inclusive? allowed-preps data
2063: &aux indexv listv ob)
2064: allowed-preps data ; unused vars
2065: (and inclusive? (loop-simple-error
2066: "INTERNED-SYMBOLS path doesn't work inclusively"
2067: variable))
2068: (and (not (null prep-phrases))
2069: (or (cdr prep-phrases)
2070: (not (si:loop-tmember (caar prep-phrases) '(in of))))
2071: (loop-simple-error
2072: "Illegal prep phrase(s) in INTERNED-SYMBOLS LOOP path"
2073: (list* variable 'being path prep-phrases)))
2074: (loop-make-variable variable () data-type)
2075: (loop-make-variable
2076: (setq ob (gensym)) (if prep-phrases (cadar prep-phrases) 'obarray) ())
2077: ; Multics lisp does not store single-char-obs in the obarray buckets.
2078: ; Thus, we need to iterate over the portion of the obarray
2079: ; containing them also. (511. = (ascii 0))
2080: (loop-make-variable
2081: (setq indexv (gensym)) #+Multics 639. #-Multics 511. 'fixnum)
2082: (loop-make-variable (setq listv (gensym)) () ())
2083: `(() ()
2084: (and #-Multics (null ,listv)
2085: #+Multics (or (> ,indexv 510.) (null ,listv))
2086: (prog ()
2087: lp (cond ((minusp (setq ,indexv (1- ,indexv))) (return t))
2088: ((setq ,listv (arraycall ; The following is the kind of
2089: ; gratuity that pisses me off:
2090: #+Multics obarray #-Multics t
2091: ,ob ,indexv))
2092: (return ()))
2093: ((go lp)))))
2094: (,variable
2095: #+Multics (cond ((> ,indexv 510.) ,listv)
2096: (t (prog2 () (car ,listv) (setq ,listv (cdr ,listv)))))
2097: #-Multics (car ,listv))
2098: ()
2099: #+Multics () #-Multics (,listv (cdr ,listv))))
2100:
2101:
2102: ;;;; Lispm interned-symbols path
2103:
2104: #+Lispm
2105: (progn 'compile
2106:
2107: (defun loop-interned-symbols-path (path variable data-type prep-phrases
2108: inclusive? allowed-preps data
2109: &aux statev1 statev2 statev3
2110: (localp (car data)))
2111: path data-type allowed-preps ; unused vars
2112: (and inclusive? (loop-simple-error
2113: "INTERNED-SYMBOLS path doesn't work inclusively"
2114: variable))
2115: (and (not (null prep-phrases))
2116: (or (cdr prep-phrases)
2117: (not (si:loop-tmember (caar prep-phrases) '(in of))))
2118: (ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A"
2119: path variable prep-phrases))
2120: (loop-make-variable variable () data-type)
2121: (loop-make-variable
2122: (setq statev1 (gensym))
2123: (if prep-phrases `(pkg-find-package ,(cadar prep-phrases)) 'package)
2124: ())
2125: (loop-make-variable (setq statev2 (gensym)) () ())
2126: (loop-make-variable (setq statev3 (gensym)) () ())
2127: (push `(multiple-value (,statev1 ,statev2 ,statev3)
2128: (loop-initialize-mapatoms-state ,statev1 ,localp))
2129: loop-prologue)
2130: `(() () (multiple-value (nil ,statev1 ,statev2 ,statev3)
2131: (,(if localp 'loop-test-and-step-mapatoms-local
2132: 'loop-test-and-step-mapatoms)
2133: ,statev1 ,statev2 ,statev3))
2134: (,variable (loop-get-mapatoms-symbol ,statev1 ,statev2 ,statev3))
2135: () ()))
2136:
2137: (defun loop-initialize-mapatoms-state (pkg localp)
2138: ; Return the initial values of the three state variables.
2139: ; This scheme uses them to be:
2140: ; (1) Index into the package (decremented as we go)
2141: ; (2) Temporary (to hold the symbol)
2142: ; (3) the package
2143: localp ; ignored
2144: (prog ()
2145: (return (array-dimension-n 2 pkg) () pkg)))
2146:
2147: (defun loop-test-and-step-mapatoms (index temp pkg)
2148: temp ; ignored
2149: (prog ()
2150: lp (cond ((< (setq index (1- index)) 0)
2151: (cond ((setq pkg (pkg-super-package pkg))
2152: (setq index (array-dimension-n 2 pkg))
2153: (go lp))
2154: (t (return t))))
2155: ((numberp (ar-2 pkg 0 index))
2156: (return nil index (ar-2 pkg 1 index) pkg))
2157: (t (go lp)))))
2158:
2159: (defun loop-test-and-step-mapatoms-local (index temp pkg)
2160: temp ; ignored
2161: (prog ()
2162: lp (cond ((minusp (setq index (1- index))) (return t))
2163: ((numberp (ar-2 pkg 0 index))
2164: (return () index (ar-2 pkg 1 index) pkg))
2165: (t (go lp)))))
2166:
2167: (defun loop-get-mapatoms-symbol (index temp pkg)
2168: index pkg ; ignored
2169: temp)
2170: )
2171:
2172: ; We don't want these defined in the compilation environment because
2173: ; the appropriate environment hasn't been set up. So, we just bootstrap
2174: ; them up.
2175: (mapc '(lambda (x)
2176: (mapc '(lambda (y)
2177: (setq loop-path-keyword-alist
2178: (cons (cons y (cdr x))
2179: (delq (si:loop-tassoc
2180: y loop-path-keyword-alist)
2181: loop-path-keyword-alist))))
2182: (car x)))
2183: '(
2184: #+(or For-NIL For-Maclisp Lispm)
2185: ((interned-symbols interned-symbol)
2186: loop-interned-symbols-path (in))
2187: #+(or For-NIL Lispm)
2188: ((local-interned-symbols local-interned-symbol)
2189: loop-interned-symbols-path (in) t)
2190: ))
2191:
2192: #-Multics ; none defined yet
2193: (mapc '(lambda (x)
2194: (mapc '(lambda (y)
2195: (setq loop-path-keyword-alist
2196: (cons `(,y si:loop-sequence-elements-path
2197: (of in from downfrom to downto below above by)
2198: . ,(cdr x))
2199: (delq (si:loop-tassoc
2200: y loop-path-keyword-alist)
2201: loop-path-keyword-alist))))
2202: (car x)))
2203: '(#+Lispm
2204: ((array-element array-elements) aref array-active-length)
2205: ; These NIL guys are set up by NILAID in the PDP10 version but no one
2206: ; sets them up on the VAX. Anyway redundancy won't hurt unless i
2207: ; break something.
2208: #+(and For-NIL (not Run-in-Maclisp))
2209: ((vector-element vector-elements) vref vector-length vector)
2210: #+(and For-NIL (not Run-in-Maclisp))
2211: ((bit bits) bit bits-length bits fixnum)
2212: #+(and For-NIL (not Run-in-Maclisp))
2213: ((character characters) char string-length string character)
2214: )
2215: )
2216:
2217: ; Sigh. (c.f. loop-featurep, note macro-expansion lossage.)
2218: ; Note that we end up doing both in the PDP10 NIL version.
2219: #+(or (not For-NIL) Run-in-Maclisp)
2220: (or (status feature loop) (sstatus feature loop))
2221: #+For-NIL
2222: (set-feature 'loop 'local)
2223:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.