Commit | Line | Data |
---|---|---|
5ffa1c4c C |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 '(#/\1c #/\1d #/\1a))) | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 |