26-loop.lisp (31299B)
1 ;; TODO : remplacer les deux my-loop-finish par loop-finish à la fin. 2 3 (defun transform-loop (expr) 4 (let* ((name nil) 5 (acc (make-symbol "ACC")) 6 (first-sym (make-symbol "FIRST")) 7 (variables nil) 8 (all-variables nil) 9 (declared-variables nil) 10 (acc-tail nil) 11 (acc-tails nil) 12 (result nil) 13 (initialization nil) 14 (loopbody nil) 15 (loopbody-sym (make-symbol "LOOPBODY")) 16 (finally nil) 17 (finally-sym (make-symbol "FINALLY")) 18 (loop-keywords '(named 19 with for as repeat 20 initially finally 21 collect append nconc sum count minimize maximize 22 while until 23 always never thereis 24 do return 25 doing 26 if when unless else end 27 and)) 28 (stack nil) 29 (conditionnal-stack nil) 30 (repeat-sym nil) 31 (destination nil) 32 (main-value nil) 33 (clause-type nil) 34 (thereis-temp (make-symbol "THERIS-TEMP")) 35 (element-getter-fun nil) 36 (for-step-fun nil) 37 (for-end-predicate nil) 38 (for-numeric-direction nil) 39 (for-numeric-start nil) 40 (for-numeric-end nil) 41 (for-numeric-step nil) 42 (for-numeric-limit nil) 43 (for-initially-psetq nil) 44 (for-initially-affect nil) 45 (storage-sym nil) 46 (vars-names nil) 47 (get-vars-and-types-end-keywords nil) 48 (destr-psetq nil) 49 (left-destr nil) 50 (right-destr nil) 51 (destr-whole-sym (make-symbol "WHOLE"))) 52 (macrolet ((advance (x) `(setq ,x (cdr ,x)))) 53 (tagbody 54 start 55 (when (eq 'named (car expr)) 56 (if (and (consp (cdr expr)) (symbolp (cadr expr))) 57 (setq name (cadr expr)) 58 (error "bootstrap : loop : expected a loop name but got ~w" (cadr expr)))) 59 ;;(go prologue) 60 prologue 61 (when (endp expr) (go end-parse)) 62 (case (car expr) 63 (with (go with)) 64 (for (go for)) 65 (as (go for)) 66 (repeat (go repeat)) 67 (initially (push 'prologue stack) (go initially)) 68 (finally (push 'prologue stack) (go finally)) 69 (otherwise (go main))) 70 (go prologue) 71 72 main 73 (when (endp expr) (go end-parse)) 74 (case (car expr) 75 (initially (push 'main stack) (go initially)) 76 (finally (push 'main stack) (go finally))) 77 (push 'main stack) 78 ;; (go main-core) 79 80 main-core 81 (case (car expr) 82 (do (go do)) 83 (return (go loop-return)) 84 ((collect collecting append appending nconc nconcing count counting sum summing minimize minimizing maximize maximizing) 85 (go accumulation)) 86 ((while until always never thereis) (go end-test-control)) 87 ((if when unless) (go conditionnal)) 88 (otherwise 89 (when (member (car expr) loop-keywords) (error "bootstrap : loop : loop keyword ~w can't appear here." (car expr))) 90 (error "bootstrap : invalid syntax in loop form : ~w." expr))) 91 92 accumulation 93 (setq clause-type (car expr)) 94 (advance expr) 95 (if (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." clause-type)) 96 (setq main-value (car expr)) 97 (advance expr) 98 (setq vars-names acc) 99 (unless (eq 'into (car expr)) (go accumulation-got-vars-2)) 100 (advance expr) 101 (setq get-vars-and-types-end-keywords nil) 102 (push 'accumulation-got-vars stack) 103 (go get-vars-and-types) 104 ;; TODO : on ne gère pas le cas "acc-clause expr type-spec" ("type-spec" sans le "into var"). Mais bon c'est tordu. 105 accumulation-got-vars 106 (when (listp vars-names) (error "bootstrap : loop : Invalid variable name for accumulation : ~w" vars-names)) 107 accumulation-got-vars-2 108 (unless (member vars-names declared-variables) 109 (push `(,vars-names ,(if (member clause-type '(count counting sum summing)) 0 nil)) variables) ;; TODO : push variables all-variables à la fin si non null 110 (push vars-names declared-variables)) 111 (when (member clause-type '(collect collecting append appending nconc nconcing)) 112 (setq acc-tail (cdr (assoc vars-names acc-tails))) 113 (unless acc-tail 114 (setq acc-tail (make-symbol "ACC-TAIL")) 115 (push `(,acc-tail nil) variables) ;; TODO : push variables all-variables à la fin si non null 116 (push `(,vars-names . ,acc-tail) acc-tails))) 117 (case clause-type 118 ((collect collecting) (go collect)) 119 ((append appending) (go append)) 120 ((nconc nconcing) (go nconc)) 121 ((count counting) (go count)) 122 ((sum summing) (go sum)) 123 ((minimize minimizing) (go minimize)) 124 ((maximize maximizing) (go maximize))) 125 126 collect 127 (setq element-getter-fun `(cons ,main-value nil)) 128 (go accumulate-list) 129 append 130 (setq element-getter-fun `(copy-list ,main-value)) 131 (go accumulate-list) 132 nconc 133 (setq element-getter-fun main-value) 134 ;; (go accumulate-list) 135 accumulate-list 136 (push `(if ,vars-names 137 (setq ,acc-tail (rplacd (last ,acc-tail) ,element-getter-fun)) 138 (setq ,acc-tail (setq ,vars-names ,element-getter-fun))) 139 loopbody) 140 (go return) 141 142 sum 143 (push `(setq ,vars-names (+ ,vars-names 1)) loopbody) 144 (go return) 145 count 146 (push `(when ,main-value (setq ,vars-names (+ ,vars-names 1))) loopbody) 147 (go return) 148 minimize 149 (setq element-getter-fun 'min) ;; Not an element-getter-fun really but I'm reclutant to add Yet Another Variable. 150 (go min-max) 151 maximize 152 (setq element-getter-fun 'min) 153 ;; (go min-max) 154 min-max 155 (push `(if ,vars-names 156 (setq ,vars-names (,element-getter-fun ,vars-names ,main-value)) 157 (setq ,vars-names ,main-value)) 158 loopbody) 159 (go return) 160 161 end-test-control 162 (setq clause-type (car expr)) 163 (advance expr) 164 (if (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." clause-type)) 165 (setq main-value (car expr)) 166 (advance expr) 167 (case clause-type 168 (while (push `(unless ,main-value (go ,finally-sym)) loopbody)) 169 (until (push `(when ,main-value (go ,finally-sym)) loopbody)) 170 (always (push `(unless ,main-value (return-from ,name nil)) loopbody) 171 (unless (member acc declared-variables) 172 (push `(,acc t) variables) 173 (push acc declared-variables))) 174 (never (push `(when ,main-value (return-from ,name nil)) loopbody) 175 (unless (member acc declared-variables) 176 (push `(,acc t) variables) 177 (push acc declared-variables))) 178 (thereis (push `(let ((,thereis-temp ,main-value)) (when ,thereis-temp (return-from ,name ,thereis-temp))) loopbody))) 179 (go return) 180 181 with 182 (advance expr) 183 (setq get-vars-and-types-end-keywords '(=)) 184 (push 'with-got-vars stack) 185 (go get-vars-and-types) 186 with-got-vars 187 (setq main-value nil) 188 (when (eq '= (car expr)) 189 (advance expr) 190 (setq main-value (car expr)) 191 (advance expr)) 192 with-make-let 193 (setq left-destr vars-names) 194 (setq right-destr main-value) 195 (push 'end-with stack) 196 (go destructuring-let) 197 end-with 198 (push variables all-variables) 199 (push nil all-variables) 200 (setq variables nil) 201 (when (eq 'and (car expr)) 202 (go with)) 203 (go prologue) 204 205 for 206 (advance expr) ;; gobble for / and 207 ;; (for vars in values) 208 ;; (for vars on values) 209 ;; (for vars = values [then expr]) 210 ;; (for vars across vector) ;; non implémenté 211 ;; being : hash et package non supportés. 212 ;; (for var [from/downfrom/upfrom expr1] [to/downto/upto/below/above expr2] [by expr3]) 213 (setq storage-sym (make-symbol "STORAGE-FOR")) 214 (setq get-vars-and-types-end-keywords '(in on = across being from downfrom upfrom to downto upto below above by)) 215 (push 'for-got-vars stack) 216 (go get-vars-and-types) 217 for-got-vars 218 (unless (member (car expr) '(in on = across being)) (go numeric-for)) 219 (setq clause-type (car expr)) 220 for-get-initial 221 (advance expr) 222 (when (endp expr) (error "bootstrap : loop : expected expression but found the end of the loop form.")) 223 (setq main-value (car expr)) 224 (advance expr) 225 for-select-clause-handler 226 (case clause-type 227 (in (go in-for)) 228 (on (go on-for)) 229 (= (go affect-then-for)) 230 (across (go vector-for)) 231 (being (go hash-package-for))) 232 (error "bootstrap : loop : serious failure while parsing the for clause handler.") 233 234 in-for 235 (setq element-getter-fun `(car ,storage-sym)) 236 (go in-on-for) 237 238 on-for 239 (setq element-getter-fun storage-sym) 240 (go in-on-for) 241 242 in-on-for 243 (setq for-step-fun `(cdr ,storage-sym)) 244 (setq for-end-predicate `(endp ,storage-sym)) 245 (when (eq 'by (car expr)) 246 (advance expr) 247 (when (endp expr) (error "bootstrap : loop : expected expression after BY but found the end of the loop form.")) 248 (setq for-step-fun `(funcall ,(car expr) ,storage-sym)) 249 (advance expr)) 250 (go for-make-let) 251 252 affect-then-for 253 (setq element-getter-fun storage-sym) 254 (setq for-step-fun storage-sym) 255 (setq for-end-predicate t) 256 (when (eq 'then (car expr)) 257 (advance expr) 258 (when (endp expr) (error "bootstrap : loop : expected expression after BY but found the end of the loop form.")) 259 (setq for-step-fun (car expr)) 260 (advance expr)) 261 (go for-make-let) 262 263 numeric-for 264 (setq for-end-predicate t) 265 (setq for-numeric-start 0) 266 (setq for-numeric-step 1) 267 (setq for-numeric-direction 0) 268 (setq for-numeric-end 0) 269 (when (member (car expr) '(from upfrom downfrom)) 270 (when (eq 'downfrom (car expr)) (setq for-numeric-direction -1)) 271 (when (eq 'upfrom (car expr)) (setq for-numeric-direction 1)) 272 (advance expr) 273 (when (endp expr) (error "bootstrap : loop : expected expression after from but found the end of the loop form.")) 274 (setq main-value (car expr)) 275 (advance expr)) 276 (when (member (car expr) '(to downto upto below above)) 277 (setq for-numeric-limit (car expr)) 278 (when (member (car expr) '(downto above)) 279 (unless (= for-numeric-direction 0) 280 (error "bootstrap : loop : do you want to go up or down ? This is not a caroussel.")) 281 (setq for-numeric-direction -1)) 282 (when (member (car expr) '(upto below)) 283 (unless (= for-numeric-direction 0) 284 (error "bootstrap : loop : do you want to go up or down ? This is not a caroussel.")) 285 (setq for-numeric-direction 1)) 286 (advance expr) 287 (when (endp expr) (error "bootstrap : loop : expected expression after ~w but found the end of the loop form." for-numeric-limit)) 288 (setq for-numeric-end (car expr)) 289 (case for-numeric-limit 290 (to (if (= for-numeric-direction -1) 291 (setq for-end-predicate `(< (car ,storage-sym) (third ,storage-sym))) 292 (setq for-end-predicate `(> (car ,storage-sym) (third ,storage-sym))))) 293 (downto (setq for-end-predicate `(< (car ,storage-sym) (third ,storage-sym)))) 294 (upto (setq for-end-predicate `(> (car ,storage-sym) (third ,storage-sym)))) 295 (below (setq for-end-predicate `(>= (car ,storage-sym) (third ,storage-sym)))) 296 (above (setq for-end-predicate `(<= (car ,storage-sym) (third ,storage-sym))))) 297 (advance expr)) 298 (when (eq 'by (car expr)) 299 (advance expr) 300 (when (endp expr) (error "bootstrap : loop : expected expression after by but found the end of the loop form.")) 301 (setq for-numeric-step (car expr)) 302 (advance expr)) 303 (setq main-value `(list ,for-numeric-start ,for-numeric-step ,for-numeric-end)) 304 (if (= -1 for-numeric-direction) 305 (setq for-step-fun `(cons (- (car ,storage-sym) (second ,storage-sym)) (cdr ,storage-sym))) 306 (setq for-step-fun `(cons (+ (car ,storage-sym) (second ,storage-sym)) (cdr ,storage-sym)))) 307 (setq element-getter-fun `(car ,storage-sym)) 308 (go for-make-let) 309 310 vector-for 311 (error "bootstrap : loop : syntax (loop for var across vector) not implemented yet !") 312 (go for-end) 313 314 hash-package-for 315 (error "bootstrap : loop : looping across hashes and packages is not implemented yet !") 316 (go for-end) 317 318 for-make-let 319 (push `(,storage-sym nil) variables) 320 (setq left-destr vars-names) 321 (push 'for-make-initially-psetq stack) 322 (go destructuring-empty-let) 323 ;; (setq left-destr vars-names) 324 ;; (setq right-destr `(funcall ,element-getter-fun (setq ,storage-sym ,main-value))) 325 ;; (push 'for-make-psetq stack) 326 ;; (go destructuring-let) 327 for-make-initially-psetq 328 (push storage-sym for-initially-psetq) 329 (push main-value for-initially-psetq) 330 (setq left-destr vars-names) 331 (setq right-destr element-getter-fun) 332 (psetq for-initially-affect destr-psetq destr-psetq for-initially-affect) ;; exchange 333 (push 'for-make-body-psetq stack) 334 (go destructuring-psetq) 335 for-make-body-psetq 336 (psetq destr-psetq for-initially-affect for-initially-affect destr-psetq) ;; re-exchange 337 (unless (eq storage-sym for-step-fun) 338 (push `(unless ,first-sym (setq ,storage-sym ,for-step-fun)) loopbody)) 339 (unless (eq t for-end-predicate) 340 (push `(when ,for-end-predicate (go ,finally-sym)) loopbody)) 341 (setq left-destr vars-names) 342 (setq right-destr element-getter-fun) 343 (push 'for-end stack) 344 (go destructuring-psetq) 345 for-end 346 (when (eq 'and (car expr)) (go for)) 347 (push variables all-variables) 348 (push `((setq ,@(reverse for-initially-psetq)) 349 (setq ,@(reverse for-initially-affect))) 350 all-variables) 351 (setq variables nil) 352 (setq for-initially-psetq nil) 353 (setq for-initially-affect nil) 354 (push `(setq ,@(reverse destr-psetq)) loopbody) 355 (setq destr-psetq nil) 356 (go prologue) 357 358 repeat 359 (advance expr) 360 (setq repeat-sym (make-symbol "REPEAT-COUNTER")) 361 (push `((,repeat-sym ,(car expr))) all-variables) 362 (push nil all-variables) 363 (push `(setq ,repeat-sym (- ,repeat-sym 1)) loopbody) 364 (push `(when (< ,repeat-sym 0) (go ,finally-sym)) loopbody) 365 (advance expr) 366 (go prologue) 367 368 do 369 (advance expr) 370 (when (endp expr) (error "bootstrap : loop : expected an expression after DO, but encountered the end of the loop form.")) 371 (when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for DO." (car expr))) 372 (push (car expr) loopbody) 373 (advance expr) 374 do-loop 375 (when (endp expr) (go do-end)) 376 (when (member (car expr) loop-keywords) (go do-end)) 377 (push (car expr) loopbody) 378 (advance expr) 379 (go do-loop) 380 do-end 381 (go return) 382 383 loop-return 384 (advance expr) 385 (when (endp expr) (error "bootstrap : loop : expected an expression after RETURN, but encountered the end of the loop form.")) 386 (push `(return-from ,name ,(car expr)) loopbody) 387 (advance expr) 388 (go return) 389 390 conditionnal 391 ;; backup loopbody 392 (push loopbody conditionnal-stack) 393 (setq loopbody nil) 394 395 (setq clause-type (car expr)) 396 (advance expr) 397 (when (endp expr) (error "bootstrap : loop : expected an expression after ~w, but encountered the end of the loop form." clause-type)) 398 (if (eq 'unless clause-type) 399 (push `(not ,(car expr)) conditionnal-stack) 400 (push (car expr) conditionnal-stack)) 401 (advance expr) 402 403 ;; get conditionnal clause 404 (push 'conditionnal-after-if-clause stack) 405 (go get-conditionnal-clause) 406 conditionnal-after-if-clause 407 408 ;; backup if-clause 409 (push loopbody conditionnal-stack) 410 (setq loopbody nil) 411 (when (eq 'end (car expr)) 412 (go conditionnal-after-else-clause)) 413 (unless (eq 'else (car expr)) 414 (go conditionnal-after-else-clause)) 415 (advance expr) 416 417 ;; get conditionnal clause 418 (push 'conditionnal-after-else-clause stack) 419 (go get-conditionnal-clause) 420 conditionnal-after-else-clause 421 422 (if (eq 'end (car expr)) (advance expr)) 423 424 (push loopbody conditionnal-stack) 425 (setq loopbody (cadddr conditionnal-stack)) 426 ;; conditionnal-stack contains (else-clause if-clause condition old-body ...) 427 (push `(if ,(caddr conditionnal-stack) (progn ,@(reverse (cadr conditionnal-stack))) (progn ,@(reverse (car conditionnal-stack)))) loopbody) 428 (setq conditionnal-stack (cddddr conditionnal-stack)) ;; pop ! 429 (go return) 430 431 get-conditionnal-clause 432 (when (endp expr) (error "Expected conditionnal if-clause or else-clause, but found the end of the loop form.")) 433 (push 'get-conditionnal-clause-loop stack) 434 (go main-core) 435 get-conditionnal-clause-loop 436 (unless (eq 'and (car expr)) (go return)) 437 (advance expr) 438 (push 'get-conditionnal-clause-loop stack) 439 (go main-core) 440 441 get-vars-and-types 442 ;; params : get-vars-and-types-end-keywords 443 ;; returns : vars-names, real-vars-names 444 445 ;; a [= 1] [and ...] 446 ;; a type [= 1] [and ...] 447 ;; a of-type type [= 1] [and ...] 448 ;; (a b c) [= <list>] [and ...] 449 ;; (a b c) (t1 t2 t3) [= <list>] [and ...] 450 ;; (a b c) of-type (t1 t2 t3) [= <list>] [and ...] 451 ;; (a b c) type [= <list>] [and ...] 452 ;; (a b c) of-type type [= <list>] [and ...] 453 (setq vars-names (car expr)) 454 (advance expr) 455 (when (eq 'of-type (car expr)) 456 (advance expr) 457 (when (endp expr) (error "Expected type after OF-TYPE, but found the end of the loop form.")) 458 (advance expr) 459 (go get-vars-and-types-end)) 460 (unless (or (member (car expr) get-vars-and-types-end-keywords) 461 (member (car expr) loop-keywords)) 462 (advance expr)) 463 get-vars-and-types-end 464 (go return) 465 466 destructuring-let 467 ;; params : left-destr right-destr 468 ;; return : nothing 469 ;; mutate : variables 470 ;; modify : left-destr 471 472 ;; Cas sans destructuring 473 (unless (consp left-destr) 474 (push `(,left-destr ,right-destr) variables) 475 (push left-destr declared-variables) 476 (go destr-let-end)) 477 478 (push `(,(car left-destr) (car (setq ,destr-whole-sym ,right-destr))) variables) 479 (push (car left-destr) declared-variables) 480 (advance left-destr) 481 destr-let-loop 482 (when (endp left-destr) 483 (go destr-let-end)) 484 (when (atom left-destr) 485 (push `(,left-destr ,destr-whole-sym) variables) 486 (push left-destr declared-variables) 487 (go destr-let-end)) 488 (push `(,(car left-destr) (car (setq ,destr-whole-sym (cdr ,destr-whole-sym)))) variables) 489 (push (car left-destr) declared-variables) 490 (advance left-destr) 491 (go destr-let-loop) 492 destr-let-end 493 (go return) 494 495 destructuring-psetq 496 ;; params : left-destr right-destr 497 ;; return : nothing 498 ;; mutate : destr-psetq 499 ;; modify : left-destr 500 501 ;; Cas sans destructuring 502 (unless (consp left-destr) 503 (push left-destr destr-psetq) 504 (push right-destr destr-psetq) 505 (go destr-psetq-end)) 506 507 (push (car left-destr) destr-psetq) 508 (push `(car (setq ,destr-whole-sym ,right-destr)) destr-psetq) 509 (advance left-destr) 510 destr-psetq-loop 511 (when (endp left-destr) 512 (go destr-psetq-end)) 513 (when (atom left-destr) 514 (push left-destr destr-psetq) 515 (push destr-whole-sym destr-psetq) 516 (go destr-psetq-end)) 517 (push (car left-destr) destr-psetq) 518 (push `(car (setq ,destr-whole-sym (cdr ,destr-whole-sym))) destr-psetq) 519 (advance left-destr) 520 (go destr-psetq-loop) 521 destr-psetq-end 522 (go return) 523 524 destructuring-empty-let 525 ;; params : left-destr 526 ;; return : nothing 527 ;; mutate : variables 528 ;; modify : left-destr 529 530 ;; Cas sans destructuring 531 (unless (consp left-destr) 532 (push `(,left-destr nil) variables) 533 (push left-destr declared-variables) 534 (go destr-empty-let-end)) 535 536 (push `(,(car left-destr) nil) variables) 537 (push (car left-destr) declared-variables) 538 (advance left-destr) 539 destr-empty-let-loop 540 (when (endp left-destr) 541 (go destr-empty-let-end)) 542 (when (atom left-destr) 543 (push `(,left-destr nil) variables) 544 (push left-destr declared-variables) 545 (go destr-empty-let-end)) 546 (push `(,(car left-destr) nil) variables) 547 (push (car left-destr) declared-variables) 548 (advance left-destr) 549 (go destr-empty-let-loop) 550 destr-empty-let-end 551 (go return) 552 553 initially 554 (advance expr) 555 (when (endp expr) (error "bootstrap : loop : expected an expression after INITIALLY, but encountered the end of the loop form.")) 556 (when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for INITIALLY." (car expr))) 557 (push (car expr) initialization) 558 (advance expr) 559 initially-step 560 (when (endp expr) (go initially-end)) 561 (when (member (car expr) loop-keywords) (go initially-end)) 562 (push (car expr) initialization) 563 (advance expr) 564 (go initially-step) 565 initially-end 566 (go return) 567 568 finally 569 (advance expr) 570 (when (eq 'return (car expr)) 571 (advance expr) 572 (when (endp expr) (error "bootstrap : loop : expected an expression after FINALLY RETURN, but encountered the end of the loop form.")) 573 (push `(return-from ,name ,(car expr)) finally) 574 (advance expr) 575 (go finally-end)) 576 (when (member (car expr) '(do doing)) 577 (advance expr)) 578 (when (endp expr) (error "bootstrap : loop : expected an expression after FINALLY, but encountered the end of the loop form.")) 579 (when (member (car expr) loop-keywords) (error "bootstrap : loop : keyword ~w can't appear here, expected expression for FINALLY." (car expr))) 580 (push (car expr) finally) 581 (advance expr) 582 ;; (go finally-step) 583 finally-step 584 (when (endp expr) (go finally-end)) 585 (when (member (car expr) loop-keywords) (go finally-end)) 586 (push (car expr) finally) 587 (advance expr) 588 (go finally-step) 589 finally-end 590 (go return) 591 592 return 593 (when (endp stack) (error "bootstrap : loop : internal error : call stack is empty !")) 594 (setq destination (car stack)) 595 (setq stack (cdr stack)) 596 (case destination 597 (prologue (go prologue)) 598 (main (go main)) 599 (with-got-vars (go with-got-vars)) 600 (end-with (go end-with)) 601 (accumulation-got-vars (go accumulation-got-vars)) 602 (for-got-vars (go for-got-vars)) 603 (for-make-initially-psetq (go for-make-initially-psetq)) 604 (for-make-body-psetq (go for-make-body-psetq)) 605 (for-end (go for-end)) 606 (conditionnal-after-if-clause (go conditionnal-after-if-clause)) 607 (conditionnal-after-else-clause (go conditionnal-after-else-clause)) 608 (get-conditionnal-clause-loop (go get-conditionnal-clause-loop)) 609 (otherwise (error "bootstrap : loop : internal error : invalid return point on call stack : ~w" destination))) 610 611 end-parse 612 (when variables 613 (push variables all-variables) 614 (push nil all-variables)) 615 make-body 616 (setq finally `(progn 617 ,@(reverse (cons `(return-from ,name 618 ,(if (member acc declared-variables) acc nil)) 619 finally)))) 620 (setq initialization (reverse initialization)) 621 (setq loopbody (reverse loopbody)) 622 (setq result 623 `(macrolet ((my-loop-finish () '(go ,finally-sym))) 624 (tagbody 625 (progn ,@initialization) 626 ,loopbody-sym 627 (progn ,@loopbody) 628 (setq ,first-sym nil) 629 (go ,loopbody-sym) 630 ,finally-sym 631 ,finally))) 632 build-lets-loop 633 (when (endp all-variables) 634 (go build-block-and-let)) 635 (setq result `(let ,(reverse (cadr all-variables)) ,@(car all-variables) ,result)) 636 (advance all-variables) 637 (advance all-variables) 638 (go build-lets-loop) 639 build-block-and-let 640 (setq result 641 `(block ,name 642 (let ((,destr-whole-sym nil) 643 (,first-sym t)) 644 ,destr-whole-sym 645 ,first-sym 646 ;; If you call loop-finish during variable declarations, and you use variables that haven't been initialized, 647 ;; then it will fail / use variables from the surrounding environment. But it's you freakin' problem if you do 648 ;; such bizarre things. 649 (macrolet ((my-loop-finish () ',finally)) 650 ,result)))) 651 the-end 652 ;; music 653 rideau)) 654 result)) 655 656 #| 657 (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) do (print i)))) 658 => 1 659 => 2 660 => 3 661 => nil 662 (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) do (print i) collect i into k append '(a a) into k finally return k))) 663 => 1 664 => 2 665 => 3 666 => '(1 a a 2 a a 3 a a) 667 (eval (transform-loop '(for (i j) in '((1 1) (2 4) (3 9)) for k from 0 to 5 do (format t "~&~a ~a ~a" i j k) initially (print 'init) (print i) finally (print 'fin) (print i)))) 668 => INIT 669 => 1 670 => 1 1 0 671 => 2 4 1 672 => 3 9 2 673 => FIN 674 => 3 675 => NIL 676 (eval (transform-loop '(for i = 42 and j in (list 1 i 3) for k = i then (cons i j) collect (list i j k)))) 677 => ((42 1 42) (42 NIL (42)) (42 3 (42 . 3))) 678 (eval (transform-loop '(for i from 1 to 10 if (evenp i) collect i else collect 'odd))) 679 => (0 ODD 2 ODD 4 ODD 6 ODD 8 ODD 10) 680 (eval (transform-loop '(for i from 1 to 10 if (evenp i) collect i and if (evenp (/ i 2)) collect 'four and append '(four) end else collect 'odd))) 681 => (0 FOUR FOUR ODD 2 ODD 4 FOUR FOUR ODD 6 ODD 8 FOUR FOUR ODD 10) 682 (eval (transform-loop '(for i from 1 to 10 unless (evenp i) collect i and if (> i 5) collect 'big and append '(something big) end else collect 'even))) 683 => (EVEN 1 EVEN 3 EVEN 5 EVEN 7 BIG SOMETHING BIG EVEN 9 BIG SOMETHING BIG EVEN) 684 (eval (transform-loop '(for i from 1 to 10 thereis (and (> i 5) i)))) 685 => 6 686 (eval (transform-loop '(for i from 1 to 10 always (< i 11)))) 687 => T 688 (eval (transform-loop '(for i from 1 to 10 always (< i 3)))) 689 => nil 690 (eval (transform-loop '(for i from 1 to 10 never (< i 0)))) 691 => T 692 (eval (transform-loop '(for i from 1 to 10 never (> i 5)))) 693 => nil 694 |# 695 696 #| 697 (loop (print 5)) 698 => boucle infinie 699 700 expansion : let, block et tagbody 701 702 (loop …) 703 expands into : 704 <prologue> 705 <body> 706 <epilogue> 707 708 expands into : 709 (block nil …) 710 pour qu'on puisse faire (return …) et (return-from nil …) 711 (loop named X …) 712 => (block X …) 713 714 do _* 715 initially _* 716 finally _* 717 Les autres ont une taille "fixe". 718 719 Attention, do peut être suivi de plusieurs tags et expressions. les tags sont comme ceux d'un tagbody, mais ne peuvent pas être des mots-clés de loop. 720 721 toutes les variables sont initialisées au début, même si elles sont déclarées au milieu 722 => (block nil (let (vars) ...)) 723 724 tous les initially sont rassemblés au début dans un progn, et tous les finally à la fin, avant le return implicite 725 => (block nil 726 (let (vars) 727 (tagbody 728 initialisation 729 (progn initially1 i2 i3 ...) 730 loopbody 731 (...) 732 (go loopbody) 733 finally 734 (progn finally1 f2 f3 ...) 735 implicit-return 736 (<implicit-return>)))) 737 738 les "with …" créent des bindings chacun dans un let, leurs valeurs sont calculées dans l'ordre d'aparition des with. 739 (loop with a = b and c = d with e = f ...) 740 => (let ((a b) 741 (c d)) 742 (let ((e f)) 743 ...)) 744 ou 745 => (let* ((#:|a| b) 746 (#:|c| d) 747 (a #:|a|) 748 (c #:|c|) 749 (#:|e| f) 750 (e #:|e|)) 751 ...) 752 753 "for …" ou "as …" 754 => initialisation : set des valeurs initiales 755 => loopbody : si on est à la fin de ce for, si oui, (go finally) 756 => si non, on exécute l'itération de ce for, et on stocke la valeur. 757 758 for x 759 => for x = 0 then (+ x 1) 760 761 for x [up|down]from 5 762 => for x = 0 then (+- x 1) 763 764 for x [up|down]from 5 [up|down]to/below/above 15 [by <step>] 765 => itération + test 766 767 "repeat <n>" 768 => initialisation d'une variable interne 769 => test si on est à la fin de ce repeat, si oui, (go finally) 770 => sinon, on incrémente cette variable interne. 771 772 "collect <expr> [into acc]" 773 (setf last-acc (setf (cdr last-acc) <expr>)) 774 si acc est absent, on accumule sur l'accumulateur par défaut. 775 776 nconc, sum, count, minimize, maximize : voir la doc 777 778 |#