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