cgit.sxemacs.org Git - sxemacs/blob - modules/cl/cl-loop.c

   1 /*
   2   cl-loop.c -- Common Lisp Goodness, the fast version
   3   Copyright (C) 2006, 2007 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt <hroptatyr@sxemacs.org>
   6
   7   * This file is part of SXEmacs.
   8   *
   9   * Redistribution and use in source and binary forms, with or without
  10   * modification, are permitted provided that the following conditions
  11   * are met:
  12   *
  13   * 1. Redistributions of source code must retain the above copyright
  14   *    notice, this list of conditions and the following disclaimer.
  15   *
  16   * 2. Redistributions in binary form must reproduce the above copyright
  17   *    notice, this list of conditions and the following disclaimer in the
  18   *    documentation and/or other materials provided with the distribution.
  19   *
  20   * 3. Neither the name of the author nor the names of any contributors
  21   *    may be used to endorse or promote products derived from this
  22   *    software without specific prior written permission.
  23   *
  24   * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  25   * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  26   * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27   * DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  28   * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  29   * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  30   * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  31   * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  32   * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  33   * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  34   * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35   */
  36
  37 /* Synched up with: Not in FSF. */
  38
  39 #include "config.h"
  40 #include <sxemacs.h>
  41 #include "cl-loop.h"
  42 #include "elhash.h"
  43 #include "ent/ent.h"
  44
  45 #if !defined EMOD_CL_MONOMOD
  46 PROVIDE(cl_loop);
  47 REQUIRE(cl_loop, "cl");
  48 #endif
  49 #define INIT    cl_loop_LTX_init
  50 #define REINIT  cl_loop_LTX_reinit
  51 #define DEINIT  cl_loop_LTX_deinit
  52
  53 static inline int
  54 emodcl_initialise_vars(Lisp_Object varform)
  55         __attribute__((always_inline));
  56 static inline void
  57 emodcl_step_vars(Lisp_Object varform, int varcount)
  58         __attribute__((always_inline));
  59
  60 Lisp_Object Qcl_loop_sentence, Qcl_loop_sentence_p;
  61 Lisp_Object Qcl_loop_for_clause, Qcl_loop_for_clause_p;
  62 Lisp_Object Qcl_loop_do_clause, Qcl_loop_do_clause_p;
  63 Lisp_Object Qcl_loop_with_clause, Qcl_loop_with_clause_p;
  64 Lisp_Object Qcl_loop_repeat_clause, Qcl_loop_repeat_clause_p;
  65 Lisp_Object Qcl_loop_append_clause, Qcl_loop_append_clause_p;
  66 Lisp_Object Qcl_loop_collect_clause, Qcl_loop_collect_clause_p;
  67 Lisp_Object Qcl_loop_nconc_clause, Qcl_loop_nconc_clause_p;
  68 Lisp_Object Qcl_loop_return_clause, Qcl_loop_return_clause_p;
  69 Lisp_Object Qcl_loop_initially_clause, Qcl_loop_initially_clause_p;
  70 Lisp_Object Qcl_loop_finally_clause, Qcl_loop_finally_clause_p;
  71 Lisp_Object Qcl_loop_count_clause, Qcl_loop_count_clause_p;
  72 Lisp_Object Qcl_loop_sum_clause, Qcl_loop_sum_clause_p;
  73 Lisp_Object Qcl_loop_maximise_clause, Qcl_loop_maximise_clause_p;
  74 Lisp_Object Qcl_loop_minimise_clause, Qcl_loop_minimise_clause_p;
  75
  76 Lisp_Object Qfor, Qas;
  77 Lisp_Object Qfrom, Qdownfrom, Qupfrom, Qto, Qdownto, Qupto, Qabove, Qbelow, Qby;
  78 Lisp_Object Qin, Qon, Qthen, Qacross, Qeach, Qthe, Qbeing, Qof;
  79 Lisp_Object Qhash_key, Qhash_keys, Qhash_value, Qhash_values, Qusing;
  80 Lisp_Object Qdo, Qdoing;
  81 Lisp_Object Qtoken;
  82 Lisp_Object Qwith, Qequals, Qand;
  83 Lisp_Object Qrepeat;
  84 Lisp_Object Qappend, Qappending, Qcollect, Qcollecting, Qnconc, Qnconcing;
  85 Lisp_Object Qinto;
  86 Lisp_Object Qcount, Qcounting, Qsum, Qsumming;
  87 Lisp_Object Qmaximise, Qmaximising, Qmaximize, Qmaximizing;
  88 Lisp_Object Qminimise, Qminimising, Qminimize, Qminimizing;
  89 Lisp_Object Qinitially, Qfinally;
  90
  91 static Lisp_Object Qanon_acn;
  92
  93 \f
  94 static int
  95 emodcl_initialise_vars(Lisp_Object varform)
  96 {
  97         /* basically a let */
  98         int idx = 0;
  99         int varcount = 0;
 100
 101         /* Make space to hold the values to give the bound variables. */
 102         GET_EXTERNAL_LIST_LENGTH(varform, varcount);
 103
 104         {
 105                 Lisp_Object temps[varcount];
 106                 struct gcpro ngcpro1;
 107
 108                 /* wipe temps first */
 109                 memset(temps, 0, sizeof(Lisp_Object)*varcount);
 110
 111                 /* Compute the values and store them in `temps' */
 112                 NGCPROn(temps, varcount);
 113
 114                 LIST_LOOP_2(var, varform) {
 115                         Lisp_Object *value = &temps[idx++];
 116                         if (SYMBOLP(var))
 117                                 *value = Qnil;
 118                         else {
 119                                 Lisp_Object tem;
 120                                 CHECK_CONS(var);
 121                                 tem = XCDR(var);
 122                                 if (NILP(tem))
 123                                         *value = Qnil;
 124                                 else {
 125                                         CHECK_CONS(tem);
 126                                         *value = Feval(XCAR(tem));
 127                                 }
 128                         }
 129                 }
 130
 131                 idx = 0;
 132
 133                 LIST_LOOP_2(var, varform) {
 134                         specbind(SYMBOLP(var) ? var : XCAR(var), temps[idx++]);
 135                 }
 136
 137                 NUNGCPRO;
 138         }
 139
 140         return varcount;
 141 }
 142
 143 static void
 144 emodcl_step_vars(Lisp_Object varform, int varcount)
 145 {
 146         /* basically a let */
 147         Lisp_Object temps[varcount];
 148         struct gcpro ngcpro1;
 149         int idx = 0;
 150
 151         /* wipe temps first */
 152         memset(temps, 0, sizeof(Lisp_Object)*varcount);
 153
 154         /* Compute the values and store them in `temps' */
 155         NGCPROn(temps, varcount);
 156
 157         LIST_LOOP_2(var, varform) {
 158                 Lisp_Object *value = &temps[idx++];
 159                 Lisp_Object tmp;
 160                 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
 161                     !NILP(XCDR(tmp))) {
 162                         /* only if there is a step form of course */
 163                         *value = Feval(XCAR(XCDR(tmp)));
 164                 }
 165         }
 166
 167         idx = 0;
 168         LIST_LOOP_2(var, varform) {
 169                 Fset(XCAR(var), temps[idx++]);
 170         }
 171
 172         NUNGCPRO;
 173         return;
 174 }
 175
 176 static int
 177 emodcl_initialise_vars_star(Lisp_Object varform)
 178 {
 179         /* basically a let* */
 180         EXTERNAL_LIST_LOOP_3(var, varform, tail) {
 181                 Lisp_Object symbol, value, tem;
 182                 if (SYMBOLP(var))
 183                         symbol = var, value = Qnil;
 184                 else {
 185                         CHECK_CONS(var);
 186                         symbol = XCAR(var);
 187                         tem = XCDR(var);
 188                         if (NILP(tem))
 189                                 value = Qnil;
 190                         else {
 191                                 CHECK_CONS(tem);
 192                                 value = Feval(XCAR(tem));
 193                         }
 194                 }
 195                 specbind(symbol, value);
 196         }
 197         return 0;
 198 }
 199
 200 static void
 201 emodcl_step_vars_star(Lisp_Object varform, int unused)
 202 {
 203         EXTERNAL_LIST_LOOP_3(var, varform, tail) {
 204                 Lisp_Object symbol, value, tmp;
 205                 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
 206                     !NILP(XCDR(tmp))) {
 207                         /* only if there is a step form of course */
 208                         symbol = XCAR(var);
 209                         value = Feval(XCAR(XCDR(tmp)));
 210                         Fset(symbol, value);
 211                 }
 212         }
 213         return;
 214 }
 215
 216 static inline Lisp_Object
 217 emodcl_do_obtain_result(Lisp_Object resultform)
 218 {
 219         /* assumes that resultform is gc-protected already */
 220         Lisp_Object result = Qnil;
 221
 222         LIST_LOOP_2(form, resultform) {
 223                 result = Feval(form);
 224         }
 225
 226         return result;
 227 }
 228
 229 static Lisp_Object
 230 emodcl_do(
 231         Lisp_Object varform, Lisp_Object endtest, Lisp_Object resultform,
 232         Lisp_Object body,
 233         int(*initialiser)(Lisp_Object), void(*stepper)(Lisp_Object, int))
 234 {
 235         Lisp_Object result = Qnil;
 236         int numbervars = 0;
 237
 238         /* initial assignment */
 239         numbervars = initialiser(varform);
 240
 241         /* now loop */
 242         while (NILP(Feval(endtest))) {
 243 #if 1
 244                 LIST_LOOP_2(form, body) {
 245                         Feval(form);
 246                 }
 247 #else
 248                 internal_catch(tag, Fprogn, body, 0);
 249 #endif
 250                 /* evaluate step forms */
 251                 stepper(varform, numbervars);
 252         }
 253
 254         /* obtain a result */
 255         result = emodcl_do_obtain_result(resultform);
 256         return result;
 257 }
 258
 259 \f
 260 /* dynacat magic */
 261 static void
 262 cl_loop_sentence_mark(Lisp_Object obj)
 263 {
 264         cl_loop_sentence_t *lsen = get_dynacat(obj);
 265
 266         EMOD_CL_DEBUG_LOOP("sentence:0x%x@0x%x shall be marked...\n",
 267                            (unsigned int)(lsen), (unsigned int)obj);
 268
 269         mark_object(lsen->prologue);
 270         mark_object(lsen->epilogue);
 271         mark_object(lsen->iteration);
 272
 273         mark_object(lsen->result);
 274         return;
 275 }
 276
 277 static void
 278 cl_loop_for_clause_mark(Lisp_Object obj)
 279 {
 280         cl_loop_for_clause_t *fc = get_dynacat(obj);
 281
 282         EMOD_CL_DEBUG_LOOP("FOR:0x%x@0x%x shall be marked...\n",
 283                            (unsigned int)(fc), (unsigned int)obj);
 284
 285         mark_object(fc->form1);
 286         mark_object(fc->from);
 287         mark_object(fc->to);
 288         mark_object(fc->by);
 289
 290         mark_object(fc->inonacross);
 291
 292         mark_object(fc->equals);
 293         mark_object(fc->then);
 294
 295         mark_object(fc->hash_keyvar);
 296         mark_object(fc->hash_valvar);
 297
 298         mark_object(fc->curval);
 299         mark_object(fc->curbound);
 300         mark_object(fc->curstep);
 301         return;
 302 }
 303
 304 static void
 305 cl_loop_do_clause_mark(Lisp_Object obj)
 306 {
 307         cl_loop_do_clause_t *doc = get_dynacat(obj);
 308
 309         EMOD_CL_DEBUG_LOOP("DO:0x%x@0x%x shall be marked...\n",
 310                            (unsigned int)(doc), (unsigned int)obj);
 311
 312         mark_object(doc->form);
 313         return;
 314 }
 315
 316 static void
 317 cl_loop_with_clause_mark(Lisp_Object obj)
 318 {
 319         cl_loop_with_clause_t *wc = get_dynacat(obj);
 320
 321         EMOD_CL_DEBUG_LOOP("WITH:0x%x@0x%x shall be marked...\n",
 322                            (unsigned int)(wc), (unsigned int)obj);
 323
 324         mark_object(wc->varform);
 325         mark_object(wc->valform);
 326         mark_object(wc->next);
 327         return;
 328 }
 329
 330 static void
 331 cl_loop_repeat_clause_mark(Lisp_Object obj)
 332 {
 333         cl_loop_repeat_clause_t *rc = get_dynacat(obj);
 334
 335         EMOD_CL_DEBUG_LOOP("REPEAT:0x%x@0x%x shall be marked...\n",
 336                            (unsigned int)(rc), (unsigned int)obj);
 337
 338         mark_object(rc->form);
 339         return;
 340 }
 341
 342 static void
 343 cl_loop_inifinret_clause_mark(Lisp_Object obj)
 344 {
 345         cl_loop_inifinret_clause_t *rc = get_dynacat(obj);
 346
 347         EMOD_CL_DEBUG_LOOP("RETURN|INITIALLY|FINALLY:"
 348                            "0x%x@0x%x shall be marked...\n",
 349                            (unsigned int)(rc), (unsigned int)obj);
 350
 351         mark_object(rc->form);
 352         return;
 353 }
 354
 355 static void
 356 cl_loop_accu_clause_mark(Lisp_Object obj)
 357 {
 358         cl_loop_accu_clause_t *ac = get_dynacat(obj);
 359
 360         EMOD_CL_DEBUG_LOOP("ACCU(=COLLECT|APPEND|NCONC|etc.):"
 361                            "0x%x@0x%x shall be marked...\n",
 362                            (unsigned int)(ac), (unsigned int)obj);
 363
 364         mark_object(ac->form);
 365         mark_object(ac->into);
 366         mark_object(ac->cur);
 367         return;
 368 }
 369
 370 static void
 371 cl_loop_generic_finaliser(Lisp_Object obj, int SXE_UNUSED(for_disksave))
 372 {
 373         void *free_me = get_dynacat(obj);
 374
 375         EMOD_CL_DEBUG_LOOP("generic:%p@%p shall be freed\n",
 376                            free_me, (void*)obj);
 377
 378         xfree(free_me);
 379         set_dynacat(obj, NULL);
 380         return;
 381 }
 382
 383 \f
 384 /* auxiliary stuff */
 385 typedef void(*cl_loop_binder_f)(Lisp_Object, Lisp_Object);
 386
 387 static int
 388 cl_loop_destructuring_bind(
 389         cl_loop_binder_f bindfun, Lisp_Object form, Lisp_Object value)
 390 {
 391         Lisp_Object tmpf, tmpv;
 392         while (!NILP(form)) {
 393                 if (SYMBOLP(form)) {
 394                         bindfun(form, value);
 395                         return 1;
 396                 }
 397                 CHECK_CONS(form);
 398                 CHECK_CONS(value);
 399                 tmpf = XCAR(form);
 400                 tmpv = XCAR(value);
 401                 /* recursive approach? :| */
 402                 cl_loop_destructuring_bind(bindfun, tmpf, tmpv);
 403                 form = XCDR(form);
 404                 value = XCDR(value);
 405         }
 406         return 1;
 407 }
 408
 409 \f
 410 /* constructors */
 411 static inline Lisp_Object
 412 cl_loop_make_sentence(void)
 413 {
 414         cl_loop_sentence_t *lsen = xnew_and_zero(cl_loop_sentence_t);
 415         Lisp_Object result = make_dynacat(lsen);
 416
 417         set_dynacat_type(result, Qcl_loop_sentence);
 418
 419         XSETDLLIST(lsen->prologue, make_dllist());
 420         XSETDLLIST(lsen->epilogue, make_dllist());
 421         XSETDLLIST(lsen->iteration, make_dllist());
 422         lsen->state = 0;
 423         lsen->result = Qnil;
 424
 425         set_dynacat_marker(result, cl_loop_sentence_mark);
 426         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 427
 428         EMOD_CL_DEBUG_LOOP("sentence:0x%x shall be wrapped to 0x%x...\n",
 429                            (unsigned int)lsen, (unsigned int)result);
 430
 431         return result;
 432 }
 433
 434 Lisp_Object
 435 cl_loop_make_for_clause(Lisp_Object form1)
 436 {
 437         cl_loop_for_clause_t *fc = xnew_and_zero(cl_loop_for_clause_t);
 438         Lisp_Object result = make_dynacat(fc);
 439
 440         set_dynacat_type(result, Qcl_loop_for_clause);
 441
 442         fc->form1 = form1;
 443         fc->for_subclause = FOR_INVALID_CLAUSE;
 444
 445         /* arith subclause */
 446         fc->from = Qzero;
 447         fc->to = Qzero;
 448         fc->by = Qone;
 449         /* by default we increment and compare with equalp */
 450         fc->byop = ASE_BINARY_OP_SUM;
 451         fc->torel = ASE_BINARY_REL_LESSP;
 452         fc->torel_strictp = 0;
 453
 454         /* in/on subclauses */
 455         fc->inonacross = Qnil;
 456
 457         /* =-then */
 458         fc->equals = Qnil;
 459         fc->then = Qnil;
 460
 461         /* hash values */
 462         fc->hash_keyvar = Qnil;
 463         fc->hash_valvar = Qnil;
 464
 465         /* for parallel bind */
 466         fc->next = Qnil;
 467         fc->depth = 1;
 468
 469         /* for runtime */
 470         fc->curval = Qnil;
 471         fc->curbound = Qzero;
 472         fc->curstep = Qone;
 473         fc->counter = 0;
 474
 475         set_dynacat_marker(result, cl_loop_for_clause_mark);
 476         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 477
 478         EMOD_CL_DEBUG_LOOP("FOR:0x%x shall be wrapped to 0x%x...\n",
 479                            (unsigned int)fc, (unsigned int)result);
 480
 481         return result;
 482 }
 483
 484 Lisp_Object
 485 cl_loop_make_do_clause(Lisp_Object form1)
 486 {
 487         cl_loop_do_clause_t *doc = xnew_and_zero(cl_loop_do_clause_t);
 488         Lisp_Object result = make_dynacat(doc);
 489
 490         set_dynacat_type(result, Qcl_loop_do_clause);
 491
 492         doc->form = form1;
 493
 494         set_dynacat_marker(result, cl_loop_do_clause_mark);
 495         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 496
 497         EMOD_CL_DEBUG_LOOP("DO:0x%x shall be wrapped to 0x%x...\n",
 498                            (unsigned int)doc, (unsigned int)result);
 499
 500         return result;
 501 }
 502
 503 Lisp_Object
 504 cl_loop_make_repeat_clause(Lisp_Object form)
 505 {
 506         cl_loop_repeat_clause_t *rc = xnew_and_zero(cl_loop_repeat_clause_t);
 507         Lisp_Object result = make_dynacat(rc);
 508
 509         set_dynacat_type(result, Qcl_loop_repeat_clause);
 510
 511         rc->form = form;
 512         rc->counter = 0;
 513
 514         set_dynacat_marker(result, cl_loop_repeat_clause_mark);
 515         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 516
 517         EMOD_CL_DEBUG_LOOP("REPEAT:0x%x shall be wrapped to 0x%x...\n",
 518                            (unsigned int)rc, (unsigned int)result);
 519
 520         return result;
 521 }
 522
 523 Lisp_Object
 524 cl_loop_make_return_clause(Lisp_Object form)
 525 {
 526         cl_loop_inifinret_clause_t *rc =
 527                 xnew_and_zero(cl_loop_inifinret_clause_t);
 528         Lisp_Object result = make_dynacat(rc);
 529
 530         set_dynacat_type(result, Qcl_loop_return_clause);
 531
 532         rc->form = form;
 533
 534         set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
 535         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 536
 537         EMOD_CL_DEBUG_LOOP("RETURN:0x%x shall be wrapped to 0x%x...\n",
 538                            (unsigned int)rc, (unsigned int)result);
 539
 540         return result;
 541 }
 542
 543 Lisp_Object
 544 cl_loop_make_initially_clause(Lisp_Object form)
 545 {
 546         cl_loop_inifinret_clause_t *rc =
 547                 xnew_and_zero(cl_loop_inifinret_clause_t);
 548         Lisp_Object result = make_dynacat(rc);
 549
 550         set_dynacat_type(result, Qcl_loop_initially_clause);
 551
 552         rc->form = form;
 553
 554         set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
 555         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 556
 557         EMOD_CL_DEBUG_LOOP("INITIALLY:0x%x shall be wrapped to 0x%x...\n",
 558                            (unsigned int)rc, (unsigned int)result);
 559
 560         return result;
 561 }
 562
 563 Lisp_Object
 564 cl_loop_make_finally_clause(Lisp_Object form)
 565 {
 566         cl_loop_inifinret_clause_t *rc =
 567                 xnew_and_zero(cl_loop_inifinret_clause_t);
 568         Lisp_Object result = make_dynacat(rc);
 569
 570         set_dynacat_type(result, Qcl_loop_finally_clause);
 571
 572         rc->form = form;
 573
 574         set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
 575         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 576
 577         EMOD_CL_DEBUG_LOOP("FINALLY:0x%x shall be wrapped to 0x%x...\n",
 578                            (unsigned int)rc, (unsigned int)result);
 579
 580         return result;
 581 }
 582
 583 /* maybe a generic cl_loop_make_accu_clause? */
 584 Lisp_Object
 585 cl_loop_make_append_clause(Lisp_Object form)
 586 {
 587         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 588         Lisp_Object result = make_dynacat(ac);
 589
 590         set_dynacat_type(result, Qcl_loop_append_clause);
 591
 592         ac->form = form;
 593         ac->into = 0;
 594         ac->cur = 0;
 595
 596         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 597         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 598
 599         EMOD_CL_DEBUG_LOOP("APPEND:0x%x shall be wrapped to 0x%x...\n",
 600                            (unsigned int)ac, (unsigned int)result);
 601
 602         return result;
 603 }
 604
 605 Lisp_Object
 606 cl_loop_make_collect_clause(Lisp_Object form)
 607 {
 608         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 609         Lisp_Object result = make_dynacat(ac);
 610
 611         set_dynacat_type(result, Qcl_loop_collect_clause);
 612
 613         ac->form = form;
 614         ac->into = 0;
 615         ac->cur = 0;
 616
 617         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 618         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 619
 620         EMOD_CL_DEBUG_LOOP("COLLECT:0x%x shall be wrapped to 0x%x...\n",
 621                            (unsigned int)ac, (unsigned int)result);
 622
 623         return result;
 624 }
 625
 626 Lisp_Object
 627 cl_loop_make_nconc_clause(Lisp_Object form)
 628 {
 629         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 630         Lisp_Object result = make_dynacat(ac);
 631
 632         set_dynacat_type(result, Qcl_loop_nconc_clause);
 633
 634         ac->form = form;
 635         ac->into = 0;
 636         ac->cur = 0;
 637
 638         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 639         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 640
 641         EMOD_CL_DEBUG_LOOP("NCONC:0x%x shall be wrapped to 0x%x...\n",
 642                            (unsigned int)ac, (unsigned int)result);
 643
 644         return result;
 645 }
 646
 647 Lisp_Object
 648 cl_loop_make_count_clause(Lisp_Object form)
 649 {
 650         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 651         Lisp_Object result = make_dynacat(ac);
 652
 653         set_dynacat_type(result, Qcl_loop_count_clause);
 654
 655         ac->form = form;
 656         ac->into = 0;
 657         ac->cur = 0;
 658
 659         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 660         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 661
 662         EMOD_CL_DEBUG_LOOP("COUNT:0x%x shall be wrapped to 0x%x...\n",
 663                            (unsigned int)ac, (unsigned int)result);
 664
 665         return result;
 666 }
 667
 668 Lisp_Object
 669 cl_loop_make_sum_clause(Lisp_Object form)
 670 {
 671         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 672         Lisp_Object result = make_dynacat(ac);
 673
 674         set_dynacat_type(result, Qcl_loop_sum_clause);
 675
 676         ac->form = form;
 677         ac->into = 0;
 678         ac->cur = 0;
 679
 680         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 681         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 682
 683         EMOD_CL_DEBUG_LOOP("SUM:0x%x shall be wrapped to 0x%x...\n",
 684                            (unsigned int)ac, (unsigned int)result);
 685
 686         return result;
 687 }
 688
 689 Lisp_Object
 690 cl_loop_make_maximise_clause(Lisp_Object form)
 691 {
 692         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 693         Lisp_Object result = make_dynacat(ac);
 694
 695         set_dynacat_type(result, Qcl_loop_maximise_clause);
 696
 697         ac->form = form;
 698         ac->into = 0;
 699         ac->cur = 0;
 700
 701         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 702         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 703
 704         EMOD_CL_DEBUG_LOOP("MAXIMISE:0x%x shall be wrapped to 0x%x...\n",
 705                            (unsigned int)ac, (unsigned int)result);
 706
 707         return result;
 708 }
 709
 710 Lisp_Object
 711 cl_loop_make_minimise_clause(Lisp_Object form)
 712 {
 713         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 714         Lisp_Object result = make_dynacat(ac);
 715
 716         set_dynacat_type(result, Qcl_loop_minimise_clause);
 717
 718         ac->form = form;
 719         ac->into = 0;
 720         ac->cur = 0;
 721
 722         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 723         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 724
 725         EMOD_CL_DEBUG_LOOP("MINIMISE:0x%x shall be wrapped to 0x%x...\n",
 726                            (unsigned int)ac, (unsigned int)result);
 727
 728         return result;
 729 }
 730
 731 Lisp_Object
 732 cl_loop_make_with_clause(Lisp_Object form)
 733 {
 734         cl_loop_with_clause_t *wc = xnew_and_zero(cl_loop_with_clause_t);
 735         Lisp_Object result = make_dynacat(wc);
 736
 737         set_dynacat_type(result, Qcl_loop_with_clause);
 738
 739         wc->varform = form;
 740         wc->valform = Qnil;
 741         wc->next = Qnil;
 742         wc->depth = 1;
 743
 744         set_dynacat_marker(result, cl_loop_with_clause_mark);
 745         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 746
 747         EMOD_CL_DEBUG_LOOP("WITH:0x%x shall be wrapped to 0x%x...\n",
 748                            (unsigned int)wc, (unsigned int)result);
 749
 750         return result;
 751 }
 752
 753 \f
 754 int
 755 cl_loop_yylex(YYSTYPE *yys, Lisp_Object *scanner,
 756               cl_loop_sentence_t *lsen, Lisp_Object *ctx, Lisp_Object *token)
 757 {
 758         Lisp_Object tok;
 759
 760         if (NILP(*scanner))
 761                 return *yys = 0;
 762
 763         tok = *token = XCAR(*scanner);
 764         *scanner = XCDR(*scanner);
 765
 766         if (EQ(tok, Qrepeat)) {
 767                 return *yys = REPEAT;
 768         }
 769         if (EQ(tok, Qfor) || EQ(tok, Qas)) {
 770                 return *yys = FOR;
 771         }
 772         if (EQ(tok, Qdo) || EQ(tok, Qdoing)) {
 773                 return *yys = DO;
 774         }
 775         if (EQ(tok, Qwith)) {
 776                 return *yys = WITH;
 777         }
 778         if (EQ(tok, Qand)) {
 779                 return *yys = AND;
 780         }
 781
 782         if (EQ(tok, Qfrom) ||
 783             EQ(tok, Qdownfrom) ||
 784             EQ(tok, Qupfrom)) {
 785                 return *yys = FROM;
 786         }
 787         if (EQ(tok, Qto) ||
 788             EQ(tok, Qdownto) ||
 789             EQ(tok, Qupto)) {
 790                 return *yys = TO;
 791         }
 792         if (EQ(tok, Qbelow)) {
 793                 return *yys = BELOW;
 794         }
 795         if (EQ(tok, Qabove)) {
 796                 return *yys = ABOVE;
 797         }
 798         if (EQ(tok, Qby)) {
 799                 return *yys = BY;
 800         }
 801         if (EQ(tok, Qin)) {
 802                 return *yys = IN;
 803         }
 804         if (EQ(tok, Qon)) {
 805                 return *yys = ON;
 806         }
 807         if (EQ(tok, Qequals)) {
 808                 return *yys = EQUALS;
 809         }
 810         if (EQ(tok, Qthen)) {
 811                 return *yys = THEN;
 812         }
 813         if (EQ(tok, Qacross)) {
 814                 return *yys = ACROSS;
 815         }
 816         if (EQ(tok, Qbeing)) {
 817                 return *yys = BEING;
 818         }
 819         if (EQ(tok, Qthe) || EQ(tok, Qeach)) {
 820                 return *yys = EACH;
 821         }
 822         if (EQ(tok, Qof) || EQ(tok, Qin)) {
 823                 return *yys = IN;
 824         }
 825         if (EQ(tok, Qhash_key) || EQ(tok, Qhash_keys)) {
 826                 return *yys = HASH_KEY;
 827         }
 828         if (EQ(tok, Qhash_value) || EQ(tok, Qhash_values)) {
 829                 return *yys = HASH_VALUE;
 830         }
 831         if (EQ(tok, Qusing)) {
 832                 return *yys = USING;
 833         }
 834         if (EQ(tok, Qcollect) || EQ(tok, Qcollecting)) {
 835                 return *yys = COLLECT;
 836         }
 837         if (EQ(tok, Qappend) || EQ(tok, Qappending)) {
 838                 return *yys = APPEND;
 839         }
 840         if (EQ(tok, Qnconc) || EQ(tok, Qnconcing)) {
 841                 return *yys = NCONC;
 842         }
 843         if (EQ(tok, Qcount) || EQ(tok, Qcount)) {
 844                 return *yys = COUNT;
 845         }
 846         if (EQ(tok, Qsum) || EQ(tok, Qsumming)) {
 847                 return *yys = SUM;
 848         }
 849         if (EQ(tok, Qminimise) || EQ(tok, Qminimising) ||
 850             EQ(tok, Qminimize) || EQ(tok, Qminimizing)) {
 851                 return *yys = MINIMISE;
 852         }
 853         if (EQ(tok, Qmaximise) || EQ(tok, Qmaximising) ||
 854             EQ(tok, Qmaximize) || EQ(tok, Qmaximizing)) {
 855                 return *yys = MAXIMISE;
 856         }
 857         if (EQ(tok, Qinto)) {
 858                 return *yys = INTO;
 859         }
 860         if (EQ(tok, Qinitially)) {
 861                 return *yys = INITIALLY;
 862         }
 863         if (EQ(tok, Qfinally)) {
 864                 return *yys = FINALLY;
 865         }
 866         if (EQ(tok, Qreturn)) {
 867                 return *yys = RETURN;
 868         }
 869
 870         return *yys = FORM;
 871 }
 872
 873 void
 874 cl_loop_yyerror(Lisp_Object *scanner, cl_loop_sentence_t *lsen,
 875                 Lisp_Object *ctx, Lisp_Object *token, char *msg)
 876 {
 877         Fsignal(Qinvalid_read_syntax, *scanner);
 878         return;
 879 }
 880
 881 \f
 882 static void
 883 cl_loop_perform_with_pro(cl_loop_with_clause_t *wc)
 884 {
 885         Lisp_Object val = Feval(wc->valform);
 886         if (wc->depth == 1) {
 887                 /* optimise for the trivial case */
 888                 cl_loop_destructuring_bind(specbind, wc->varform, val);
 889         } else {
 890                 Lisp_Object *tmp = alloca_array(Lisp_Object, wc->depth);
 891                 size_t i;
 892                 Lisp_Object tra;
 893
 894                 tmp[0] = val;
 895                 tra = wc->next;
 896                 for (i = 1; !NILP(tra); i++) {
 897                         cl_loop_with_clause_t *wct = get_dynacat(tra);
 898                         tmp[i] = Feval(wct->valform);
 899                         tra = wct->next;
 900                 }
 901
 902                 /* now specbind them */
 903                 cl_loop_destructuring_bind(specbind, wc->varform, tmp[0]);
 904                 tra = wc->next;
 905                 for (i = 1; !NILP(tra); i++) {
 906                         cl_loop_with_clause_t *wct = get_dynacat(tra);
 907                         cl_loop_destructuring_bind(
 908                                 specbind, wct->varform, tmp[i]);
 909                         tra = wct->next;
 910                 }
 911         }
 912 }
 913
 914 static inline void
 915 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
 916         __attribute__((always_inline));
 917 static inline void
 918 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
 919 {
 920         if (ac->into == Qnull_pointer) {
 921                 /* generate a random symbol */
 922                 ac->into = Qanon_acn;
 923         }
 924         specbind(ac->into, ac->cur = Qnil);
 925 }
 926
 927 static inline void
 928 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
 929         __attribute__((always_inline));
 930 static inline void
 931 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
 932 {
 933         if (ac->into == Qnull_pointer) {
 934                 /* generate a random symbol */
 935                 ac->into = Qanon_acn;
 936         }
 937         specbind(ac->into, ac->cur = Qzero);
 938 }
 939
 940 static inline void
 941 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
 942         __attribute__((always_inline));
 943 static inline void
 944 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
 945 {
 946         if (ac->into == Qnull_pointer) {
 947                 /* generate a random symbol */
 948                 ac->into = Qanon_acn;
 949         }
 950         specbind(ac->into, ac->cur = Vninfinity);
 951 }
 952
 953 static inline void
 954 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
 955         __attribute__((always_inline));
 956 static inline void
 957 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
 958 {
 959         if (ac->into == Qnull_pointer) {
 960                 /* generate a random symbol */
 961                 ac->into = Qanon_acn;
 962         }
 963         specbind(ac->into, ac->cur = Vpinfinity);
 964 }
 965
 966 static inline void
 967 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
 968         __attribute__((always_inline));
 969 static inline void
 970 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
 971 {
 972         Lisp_Object lctr = Feval(rc->form);
 973         CHECK_INT(lctr);
 974         rc->counter = XINT(lctr);
 975         return;
 976 }
 977
 978 static inline void
 979 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
 980         __attribute__((always_inline));
 981 static inline void
 982 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
 983 {
 984         Feval(rc->form);
 985         return;
 986 }
 987
 988 static hentry_t
 989 cl_loop_next_hentry(hentry_t e, const hash_table_t ht)
 990 {
 991         const hentry_t term = ht->hentries + ht->size;
 992         if (e == NULL) {
 993                 e = ht->hentries;
 994                 e--;
 995         }
 996
 997         while (e < term && HENTRY_CLEAR_P(++e));
 998
 999         if (e < term)
1000                 return e;
1001         else
1002                 return NULL;
1003 }
1004
1005 static void
1006 cl_loop_perform_for_pro_i(cl_loop_for_clause_t *fc)
1007 {
1008         switch (fc->for_subclause) {
1009         case FOR_ARITHMETIC_CLAUSE:
1010                 fc->curval = Feval(fc->from);
1011                 fc->curbound = Feval(fc->to);
1012                 fc->curstep = Feval(fc->by);
1013                 break;
1014         case FOR_IN_SUBLIST_CLAUSE:
1015                 fc->curbound = Feval(fc->inonacross);
1016                 /* error handling here, make sure curbound is a cons */
1017                 CHECK_CONS(fc->curbound);
1018                 fc->curval = XCAR(fc->curbound);
1019                 break;
1020         case FOR_ON_SUBLIST_CLAUSE:
1021                 fc->curbound = Feval(fc->inonacross);
1022                 CHECK_CONS(fc->curbound);
1023                 fc->curval = fc->curbound;
1024                 break;
1025         case FOR_ACROSS_ARRAY_CLAUSE:
1026                 fc->curbound = Feval(fc->inonacross);
1027                 fc->bound = XINT(Flength(fc->curbound));
1028                 /* CHECK_ARRAY(fc->curbound); */
1029                 fc->counter = 0;
1030                 fc->curval = Faref(fc->curbound, Qzero);
1031                 break;
1032         case FOR_EQUALS_THEN_CLAUSE:
1033                 fc->curval = Feval(fc->equals);
1034                 fc->counter = 0;
1035                 break;
1036         case FOR_OF_HASHTABLE_CLAUSE: {
1037                 hentry_t e;
1038                 fc->curbound = Feval(fc->inonacross);
1039                 e = cl_loop_next_hentry(
1040                         NULL, XHASH_TABLE(fc->curbound));
1041                 if ((fc->ptr1 = e) == NULL) {
1042                         return;
1043                 }
1044                 fc->curval = Qnil;
1045                 return;
1046         }
1047         case FOR_INVALID_CLAUSE:
1048         default:
1049                 /* there are `for' subclauses without stuff in the prologue */
1050                 break;
1051         }
1052         return;
1053 }
1054
1055 static void
1056 cl_loop_perform_for_pro_b(cl_loop_for_clause_t *fc)
1057 {
1058         switch (fc->for_subclause) {
1059         case FOR_ARITHMETIC_CLAUSE:
1060         case FOR_IN_SUBLIST_CLAUSE:
1061         case FOR_ON_SUBLIST_CLAUSE:
1062         case FOR_ACROSS_ARRAY_CLAUSE:
1063         case FOR_EQUALS_THEN_CLAUSE:
1064                 cl_loop_destructuring_bind(specbind, fc->form1, fc->curval);
1065                 break;
1066
1067         case FOR_OF_HASHTABLE_CLAUSE: {
1068                 hentry_t e = fc->ptr1;
1069                 if (e == NULL) {
1070                         return;
1071                 }
1072                 if (!NILP(fc->hash_keyvar)) {
1073                         cl_loop_destructuring_bind(
1074                                 specbind, fc->hash_keyvar, e->key);
1075                 }
1076                 if (!NILP(fc->hash_valvar)) {
1077                         cl_loop_destructuring_bind(
1078                                 specbind, fc->hash_valvar, e->value);
1079                 }
1080                 return;
1081         }
1082         case FOR_INVALID_CLAUSE:
1083         default:
1084                 /* there are `for' subclauses without stuff in the prologue */
1085                 break;
1086         }
1087         return;
1088 }
1089
1090 static void
1091 cl_loop_perform_for_pro(cl_loop_for_clause_t *fc)
1092 {
1093         if (fc->depth == 1) {
1094                 /* optimise for the trivial case */
1095                 cl_loop_perform_for_pro_i(fc);
1096                 cl_loop_perform_for_pro_b(fc);
1097                 return;
1098         } else {
1099                 Lisp_Object tra;
1100
1101                 cl_loop_perform_for_pro_i(fc);
1102                 tra = fc->next;
1103                 while (!NILP(tra)) {
1104                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1105                         cl_loop_perform_for_pro_i(fct);
1106                         tra = fct->next;
1107                 }
1108
1109                 /* now specbind them */
1110                 cl_loop_perform_for_pro_b(fc);
1111                 tra = fc->next;
1112                 while (!NILP(tra)) {
1113                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1114                         cl_loop_perform_for_pro_b(fct);
1115                         tra = fct->next;
1116                 }
1117         }
1118 }
1119
1120 static void
1121 cl_loop_perform_for_i(cl_loop_for_clause_t *fc)
1122 {
1123         /* non stepping stuff */
1124         switch (fc->for_subclause) {
1125         case FOR_EQUALS_THEN_CLAUSE:
1126                 if (fc->counter++) {
1127                         cl_loop_destructuring_bind(
1128                                 (cl_loop_binder_f)Fset, fc->form1,
1129                                 fc->curval = Feval(fc->then));
1130                 }
1131                 return;
1132         case FOR_INVALID_CLAUSE:
1133         case FOR_ARITHMETIC_CLAUSE:
1134         case FOR_IN_SUBLIST_CLAUSE:
1135         case FOR_ON_SUBLIST_CLAUSE:
1136         case FOR_ACROSS_ARRAY_CLAUSE:
1137         case FOR_OF_HASHTABLE_CLAUSE:
1138         default:
1139                 break;
1140         }
1141         return;
1142 }
1143
1144 static int
1145 cl_loop_perform_for_b(cl_loop_for_clause_t *fc)
1146 {
1147         switch (fc->for_subclause) {
1148         case FOR_ARITHMETIC_CLAUSE:
1149         case FOR_IN_SUBLIST_CLAUSE:
1150         case FOR_ON_SUBLIST_CLAUSE:
1151         case FOR_ACROSS_ARRAY_CLAUSE:
1152                 /* bind to the value computed during the last iteration */
1153                 cl_loop_destructuring_bind(
1154                         (cl_loop_binder_f)Fset, fc->form1, fc->curval);
1155         case FOR_INVALID_CLAUSE:
1156         case FOR_OF_HASHTABLE_CLAUSE:
1157         case FOR_EQUALS_THEN_CLAUSE:
1158         default:
1159                 break;
1160         }
1161
1162         /* most clauses step in this fun */
1163         switch (fc->for_subclause) {
1164         case FOR_EQUALS_THEN_CLAUSE:
1165                 return 1;
1166         case FOR_ARITHMETIC_CLAUSE:
1167                 fc->curval = ent_binop(fc->byop, fc->curval, fc->curstep);
1168                 if (!fc->torel_strictp) {
1169                         return ent_binrel2(fc->torel, ASE_BINARY_REL_EQUALP,
1170                                            fc->curval, fc->curbound);
1171                 } else {
1172                         return ent_binrel(fc->torel, fc->curval, fc->curbound);
1173                 }
1174                 break;
1175         case FOR_IN_SUBLIST_CLAUSE:
1176                 /* error handling here, make sure curbound is a cons */
1177                 fc->curbound = XCDR(fc->curbound);
1178                 if (NILP(fc->curbound))
1179                         return 0;
1180                 fc->curval = XCAR(fc->curbound);
1181                 return 1;
1182                 break;
1183         case FOR_ON_SUBLIST_CLAUSE:
1184                 /* error handling here, make sure curbound is a cons */
1185                 if (NILP(fc->curval = XCDR(fc->curval)))
1186                         return 0;
1187                 return 1;
1188                 break;
1189         case FOR_ACROSS_ARRAY_CLAUSE:
1190                 fc->counter++;
1191                 if (fc->counter >= fc->bound)
1192                         return 0;
1193                 fc->curval = Faref(fc->curbound, make_int(fc->counter));
1194                 return 1;
1195                 break;
1196         case FOR_OF_HASHTABLE_CLAUSE: {
1197                 hentry_t e = fc->ptr1;
1198                 if (e == NULL) {
1199                         return 0;
1200                 }
1201                 if (!NILP(fc->hash_keyvar)) {
1202                         cl_loop_destructuring_bind(
1203                                 (cl_loop_binder_f)Fset,
1204                                 fc->hash_keyvar, e->key);
1205                 }
1206                 if (!NILP(fc->hash_valvar)) {
1207                         cl_loop_destructuring_bind(
1208                                 (cl_loop_binder_f)Fset,
1209                                 fc->hash_valvar, e->value);
1210                 }
1211                 fc->ptr1 = cl_loop_next_hentry(e, XHASH_TABLE(fc->curbound));
1212                 return 1;
1213         }
1214         case FOR_INVALID_CLAUSE:
1215         default:
1216                 break;
1217         }
1218         return 1;
1219 }
1220
1221 static inline int
1222 cl_loop_perform_for(cl_loop_for_clause_t *fc)
1223 {
1224         if (fc->depth == 1) {
1225                 /* optimise for the trivial case */
1226                 cl_loop_perform_for_i(fc);
1227                 return cl_loop_perform_for_b(fc);
1228         } else {
1229                 Lisp_Object tra;
1230                 int state;
1231
1232                 cl_loop_perform_for_i(fc);
1233                 tra = fc->next;
1234                 while (!NILP(tra)) {
1235                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1236                         cl_loop_perform_for_i(fct);
1237                         tra = fct->next;
1238                 }
1239
1240                 /* now specbind them */
1241                 state = cl_loop_perform_for_b(fc);
1242                 tra = fc->next;
1243                 while (!NILP(tra)) {
1244                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1245                         state &= cl_loop_perform_for_b(fct);
1246                         tra = fct->next;
1247                 }
1248                 return state;
1249         }
1250 }
1251
1252 static inline int
1253 cl_loop_perform_do(cl_loop_do_clause_t *dc)
1254 {
1255         Feval(dc->form);
1256         return 1;
1257 }
1258
1259 static inline int
1260 cl_loop_perform_repeat(cl_loop_repeat_clause_t *rc)
1261 {
1262         if (--rc->counter > 0) {
1263                 return 1;
1264         }
1265         return 0;
1266 }
1267
1268 static inline int
1269 cl_loop_perform_collect(cl_loop_accu_clause_t *ac)
1270 {
1271         if (!NILP(ac->cur))
1272                 ac->cur = XCDR(ac->cur) = Fcons(Feval(ac->form), Qnil);
1273         else {
1274                 Fset(ac->into, ac->cur = Fcons(Feval(ac->form), Qnil));
1275         }
1276         return 1;
1277 }
1278
1279 static inline int
1280 cl_loop_perform_append(cl_loop_accu_clause_t *ac)
1281 {
1282         Lisp_Object form = Feval(ac->form);
1283         CHECK_CONS(form);
1284         if (!NILP(ac->cur))
1285                 XCDR(ac->cur) = form;
1286         else {
1287                 Fset(ac->into, ac->cur = form);
1288         }
1289         while (!NILP(XCDR(ac->cur)) && CONSP(XCDR(ac->cur)))
1290                 ac->cur = XCDR(ac->cur);
1291         if (CONSP(ac->cur) && NILP(XCDR(ac->cur)))
1292                 return 1;
1293         else
1294                 return wrong_type_argument(Qlistp, form);
1295 }
1296
1297 static inline int
1298 cl_loop_perform_nconc(cl_loop_accu_clause_t *ac)
1299 {
1300         Lisp_Object form = Feval(ac->form);
1301         if (!NILP(ac->cur) && CONSP(ac->cur)) {
1302                 XCDR(ac->cur) = form;
1303         } else {
1304                 Fset(ac->into, ac->cur = form);
1305         }
1306         while (CONSP(ac->cur) &&
1307                !NILP(XCDR(ac->cur)) &&
1308                CONSP(XCDR(ac->cur)))
1309                 ac->cur = XCDR(ac->cur);
1310         return 1;
1311 }
1312
1313 static inline int
1314 cl_loop_perform_count(cl_loop_accu_clause_t *ac)
1315 {
1316         if (!NILP(Feval(ac->form))) {
1317                 Fset(ac->into, ac->cur = make_int(XINT(ac->cur)+1));
1318         }
1319         return 1;
1320 }
1321
1322 static inline int
1323 cl_loop_perform_sum(cl_loop_accu_clause_t *ac)
1324 {
1325         Lisp_Object form = Feval(ac->form);
1326         CHECK_NUMBER(form);
1327         Fset(ac->into,
1328              ac->cur = ent_binop(ASE_BINARY_OP_SUM, ac->cur, form));
1329         return 1;
1330 }
1331
1332 static inline int
1333 cl_loop_perform_maximise(cl_loop_accu_clause_t *ac)
1334 {
1335         Lisp_Object form = Feval(ac->form);
1336         CHECK_NUMBER(form);
1337         if (ent_binrel(ASE_BINARY_REL_GREATERP, form, ac->cur))
1338                 Fset(ac->into, ac->cur = form);
1339         return 1;
1340 }
1341
1342 static inline int
1343 cl_loop_perform_minimise(cl_loop_accu_clause_t *ac)
1344 {
1345         Lisp_Object form = Feval(ac->form);
1346         CHECK_NUMBER(form);
1347         if (ent_binrel(ASE_BINARY_REL_LESSP, form, ac->cur))
1348                 Fset(ac->into, ac->cur = form);
1349         return 1;
1350 }
1351
1352 static inline Lisp_Object
1353 cl_loop_perform_accu_epi()
1354         __attribute__((always_inline));
1355 static inline Lisp_Object
1356 cl_loop_perform_accu_epi(
1357         Lisp_Object *SXE_UNUSED(result), cl_loop_accu_clause_t *ac)
1358 {
1359         return symbol_value(XSYMBOL(ac->into));
1360 }
1361
1362 static inline Lisp_Object
1363 cl_loop_perform_finally_epi()
1364         __attribute__((always_inline));
1365 static inline Lisp_Object
1366 cl_loop_perform_finally_epi(
1367         Lisp_Object *SXE_UNUSED(result), cl_loop_inifinret_clause_t *rc)
1368 {
1369         return Feval(rc->form);
1370 }
1371
1372 static inline Lisp_Object
1373 cl_loop_perform_return_epi()
1374         __attribute__((always_inline));
1375 static inline Lisp_Object
1376 cl_loop_perform_return_epi(
1377         Lisp_Object *result, cl_loop_inifinret_clause_t *rc)
1378 {
1379         return *result = Feval(rc->form);
1380 }
1381
1382 \f
1383 static int
1384 cl_loop_prologue(Lisp_Object clause)
1385 {
1386         void *emp = NULL;
1387
1388         emp = get_dynacat(clause);
1389         if (EQ(get_dynacat_type(clause), Qcl_loop_repeat_clause)) {
1390                 cl_loop_perform_repeat_pro(emp);
1391                 return 1;
1392         }
1393         if (EQ(get_dynacat_type(clause), Qcl_loop_for_clause)) {
1394                 cl_loop_perform_for_pro(emp);
1395                 return 1;
1396         }
1397         if (EQ(get_dynacat_type(clause), Qcl_loop_with_clause)) {
1398                 cl_loop_perform_with_pro(emp);
1399                 return 1;
1400         }
1401         if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause)) {
1402                 cl_loop_perform_colappnco_pro(emp);
1403                 return 1;
1404         }
1405         if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1406                 cl_loop_perform_colappnco_pro(emp);
1407                 return 1;
1408         }
1409         if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1410                 cl_loop_perform_colappnco_pro(emp);
1411                 return 1;
1412         }
1413         if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1414                 cl_loop_perform_countsum_pro(emp);
1415                 return 1;
1416         }
1417         if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1418                 cl_loop_perform_countsum_pro(emp);
1419                 return 1;
1420         }
1421         if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1422                 cl_loop_perform_maximise_pro(emp);
1423                 return 1;
1424         }
1425         if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1426                 cl_loop_perform_minimise_pro(emp);
1427                 return 1;
1428         }
1429         if (EQ(get_dynacat_type(clause), Qcl_loop_initially_clause)) {
1430                 cl_loop_perform_initially_pro(emp);
1431                 return 1;
1432         }
1433
1434         return 1;
1435 }
1436
1437 static Lisp_Object
1438 cl_loop_epilogue(Lisp_Object *result, Lisp_Object clause)
1439 {
1440         void *emp = NULL;
1441
1442         emp = get_dynacat(clause);
1443         if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause)) {
1444                 return cl_loop_perform_accu_epi(result, emp);
1445         }
1446         if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1447                 return cl_loop_perform_accu_epi(result, emp);
1448         }
1449         if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1450                 return cl_loop_perform_accu_epi(result, emp);
1451         }
1452         if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1453                 return cl_loop_perform_accu_epi(result, emp);
1454         }
1455         if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1456                 return cl_loop_perform_accu_epi(result, emp);
1457         }
1458         if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1459                 return cl_loop_perform_accu_epi(result, emp);
1460         }
1461         if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1462                 return cl_loop_perform_accu_epi(result, emp);
1463         }
1464         if (EQ(get_dynacat_type(clause), Qcl_loop_return_clause)) {
1465                 return cl_loop_perform_return_epi(result, emp);
1466         }
1467         if (EQ(get_dynacat_type(clause), Qcl_loop_finally_clause)) {
1468                 return cl_loop_perform_finally_epi(result, emp);
1469         }
1470         return Qnull_pointer;
1471 }
1472
1473 static int
1474 cl_loop_iteration(Lisp_Object clause)
1475 {
1476         void *emp = NULL;
1477
1478         emp = get_dynacat(clause);
1479         if (EQ(get_dynacat_type(clause), Qcl_loop_repeat_clause))
1480                 return cl_loop_perform_repeat(emp);
1481         if (EQ(get_dynacat_type(clause), Qcl_loop_for_clause))
1482                 return cl_loop_perform_for(emp);
1483         if (EQ(get_dynacat_type(clause), Qcl_loop_do_clause))
1484                 return cl_loop_perform_do(emp);
1485         if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause))
1486                 return cl_loop_perform_collect(emp);
1487         if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause))
1488                 return cl_loop_perform_append(emp);
1489         if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause))
1490                 return cl_loop_perform_nconc(emp);
1491         if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause))
1492                 return cl_loop_perform_count(emp);
1493         if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause))
1494                 return cl_loop_perform_sum(emp);
1495         if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause))
1496                 return cl_loop_perform_maximise(emp);
1497         if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause))
1498                 return cl_loop_perform_minimise(emp);
1499
1500         return 0;
1501 }
1502
1503 static int
1504 cl_loop_dllist_map(int(*fun)(Lisp_Object), dllist_t dll)
1505 {
1506         int state;
1507         dllist_item_t item = dllist_first(dll);
1508
1509         if (item == NULL) {
1510                 return 0;
1511         }
1512
1513         state = 1;
1514         while (item) {
1515                 state &= fun((Lisp_Object)item->item);
1516                 item = item->next;
1517         }
1518         return state;
1519 }
1520
1521 static Lisp_Object
1522 cl_loop_dllist_map_return(
1523         Lisp_Object *result,
1524         Lisp_Object(*fun)(Lisp_Object*, Lisp_Object), dllist_t dll)
1525 {
1526         dllist_item_t item = dllist_first(dll);
1527         Lisp_Object ret = Qnil;
1528
1529         if (item == NULL) {
1530                 return Qnil;
1531         }
1532
1533         while (item) {
1534                 ret = fun(result, (Lisp_Object)item->item);
1535                 item = item->next;
1536         }
1537         if (!EQ(ret, Qnull_pointer))
1538                 return ret;
1539         else
1540                 return Qnil;
1541 }
1542
1543 static Lisp_Object
1544 cl_loop_perform(cl_loop_sentence_t *lsen)
1545 {
1546         dllist_t pro = XDLLIST(lsen->prologue);
1547         dllist_t epi = XDLLIST(lsen->epilogue);
1548         dllist_t iter = XDLLIST(lsen->iteration);
1549         int speccount = specpdl_depth();
1550         Lisp_Object res;
1551
1552         lsen->state = 1;
1553
1554         /* traverse the prologue */
1555         cl_loop_dllist_map(cl_loop_prologue, pro);
1556         /* traverse the iteration */
1557         while (lsen->state) {
1558                 QUIT;
1559                 lsen->state = cl_loop_dllist_map(cl_loop_iteration, iter);
1560         }
1561         /* traverse the epilogue */
1562         lsen->result = Qnull_pointer;
1563         res = cl_loop_dllist_map_return(&lsen->result, cl_loop_epilogue, epi);
1564
1565         unbind_to(speccount, Qnil);
1566         if (lsen->result)
1567                 return lsen->result;
1568         else
1569                 return res;
1570 }
1571
1572 \f
1573 /* ###autoload */
1574 DEFUN("cl:loop-sentence", Fcl_loop_sentence, 0, UNEVALLED, 0, /*
1575 Part of The Common Lisp loop macro.
1576 See: `cl:loop'
1577                                                               */
1578       (args))
1579 {
1580         Lisp_Object loop_sentence = cl_loop_make_sentence();
1581         Lisp_Object context = Qnil, token = Qnil;
1582         cl_loop_sentence_t *lsen = get_dynacat(loop_sentence);
1583         int parse_result;
1584         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1585
1586         GCPRO4(args, loop_sentence, context, token);
1587
1588         /* now parse the stuff */
1589         parse_result = cl_loop_yyparse(&args, lsen, &context, &token);
1590         (void)parse_result;
1591
1592         UNGCPRO;
1593         return loop_sentence;
1594 }
1595
1596 DEFUN("cl:loop*", Fcl_loopX, 1, 1, 0, /*
1597 Execute LOOP-SENTENCE.
1598 */
1599       (loop_sentence))
1600 {
1601         Lisp_Object result = Qnil;
1602         struct gcpro gcpro1, gcpro2;
1603
1604         CHECK_CL_LOOP_SENTENCE(loop_sentence);
1605
1606         GCPRO2(result, loop_sentence);
1607
1608         result = cl_loop_perform(XCL_LOOP_SENTENCE(loop_sentence));
1609
1610         UNGCPRO;
1611         return result;
1612 }
1613
1614 DEFUN("cl:loop", Fcl_loop, 0, UNEVALLED, 0, /*
1615 (loop CLAUSE...): The Common Lisp loop macro.
1616
1617 Overview of valid clauses:
1618   for VAR from/upfrom/downfrom NUM to/upto/downto/above/below NUM by NUM,
1619   for VAR in LIST by FUNC, for VAR on LIST by FUNC, for VAR = INIT then EXPR,
1620   for VAR across ARRAY, repeat NUM, with VAR = INIT, while COND, until COND,
1621   always COND, never COND, thereis COND, collect EXPR into VAR,
1622   append EXPR into VAR, nconc EXPR into VAR, sum EXPR into VAR,
1623   count EXPR into VAR, maximize EXPR into VAR, minimize EXPR into VAR,
1624   if COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
1625   unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...],
1626   do EXPRS..., initially EXPRS..., finally EXPRS..., return EXPR,
1627   finally return EXPR, named NAME.
1628
1629 The loop macro consists of a series of clauses, which do things like
1630 iterate variables, set conditions for exiting the loop, accumulating values
1631 to be returned as the return value of the loop, and executing arbitrary
1632 blocks of code.  Each clause is proceed in turn, and the loop executes its
1633 body repeatedly until an exit condition is hit.
1634
1635 It's important to understand that loop clauses such as `for' and `while',
1636 which look like loop-establishing constructs, don't actually *establish* a
1637 loop; the looping is established by the `loop' clause itself, which will
1638 repeatedly process its body until told to stop.  `while' merely establishes
1639 a condition which, when true, causes the loop to finish, and `for' sets a
1640 variable to different values on each iteration (e.g. successive elements of
1641 a list) and sets an exit condition when there are no more values.  This
1642 means, for example, that if two `for' clauses appear, you don't get two
1643 nested loops, but instead two variables that are stepped in parallel, and
1644 two exit conditions, either of which, if triggered, will cause the loop to
1645 end.  Similarly for a loop with a `for' and a `while' clause.  For example:
1646
1647 (loop
1648   for x in list
1649   while x
1650   do ...)
1651
1652 In each successive iteration, X is set to the next element of the list.  If
1653 there are no more elements, or if any element is nil (the `while' clause),
1654 the loop exits.  Otherwise, the block of code following `do' is executed.)
1655
1656 This example also shows that some clauses establish variable bindings --
1657 essentially like a `let' binding -- and that following clauses can
1658 reference these variables.  Furthermore, the entire loop is surrounded by a
1659 block named nil (unless the `named' clause is given), so you can return
1660 from the loop using the macro `return'. (The other way to exit the loop is
1661 through the macro `loop-finish'.  The difference is that some loop clauses
1662 establish or accumulate a value to be returned, and `loop-finish' returns
1663 this. `return', however, can only return an explicitly-specified value.
1664 NOTE CAREFULLY: There is a loop clause called `return' as well as a
1665 standard Lisp macro called `return'.  Normally they work similarly; but if
1666 you give the loop a name with `named', you will need to use the macro
1667 `return-from'.)
1668
1669 Another extremely useful feature of loops is called "destructuring".  If,
1670 in place of VAR, a list (possibly dotted, possibly a tree of arbitary
1671 complexity) is given, the value to be assigned is assumed to have a similar
1672 structure to the list given, and variables in the list will be matched up
1673 with corresponding elements in the structure.  For example:
1674
1675 (loop
1676   for (x y) in '((foo 1) (bar 2) (baz 3))
1677   do (puthash x y some-hash-table))
1678
1679 will add three elements to a hash table, mapping foo -> 1, bar -> 2, and
1680 baz -> 3.  As other examples, you can conveniently process alists using
1681
1682 (loop for (x . y) in alist do ...)
1683
1684 and plists using
1685
1686 (loop for (x y) on plist by #'cddr do ...)
1687
1688 Destructuring is forgiving in that mismatches in the number of elements on
1689 either size will be handled gracefully, either by ignoring or initializing
1690 to nil.
1691
1692 If you don't understand how a particular loop clause works, create an
1693 example and use `macroexpand-sexp' to expand the macro.
1694
1695 In greater detail, valid clauses are:
1696
1697 (NOTE: Keywords in lowercase; slashes separate different possibilities
1698 for keywords, some of which are synonymous; brackets indicate optional
1699 parts of the clause.  In all of the clauses with `being', the word `being',
1700 the words `each' or `the', and the difference between singular and plural
1701 keywords are all just syntactic sugar.  Stylistically, you should write
1702 either `being each foo' or `being the foos'.)
1703
1704   for VAR from/upfrom/downfrom NUM1 to/upto/downto/above/below NUM2 [by NUMSTEP]
1705     Step VAR across numbers.  `upfrom', `upto', and `below' explicitly
1706     indicate upward stepping; `downfrom', `downto', and `above' explicitly
1707     indicate downward stepping. (If none of these is given, the default is
1708     upward.) `to', `upto', and `downto' cause stepping to include NUM2 as
1709     the last iteration, while `above' and `below' stop just before reaching
1710     NUM2.  `by' can be given to indicate a stepping increment other than 1.
1711
1712   for VAR in LIST [by FUNC]
1713     Step VAR over elements of a LIST.  FUNC specifies how to get successive
1714     sublists and defaults to `cdr'.
1715
1716   for VAR on LIST [by FUNC]
1717     Step VAR over tails of a LIST.  FUNC specifies how to get successive
1718     sublists and defaults to `cdr'.
1719
1720   for VAR in-ref LIST [by FUNC]
1721     Step VAR over elements of a LIST, like `for ... in', except the VAR is
1722     bound using `symbol-macrolet' instead of `let'.  In essence, VAR is set
1723     to a "reference" to the list element instead of the element itself;
1724     this us, you can destructively modify the list using `setf' on VAR, and
1725     any changes to the list will "magically" reflect themselves in
1726     subsequent uses of VAR.
1727
1728   for VAR = INIT [then EXPR]
1729     Set VAR on each iteration of the loop.  If only INIT is given, use it
1730     on each iteration.  Otherwise, use INIT on the first iteration and EXPR
1731     on subsequent ones.
1732
1733   for VAR across/across-ref ARRAY
1734     Step VAR across a sequence other than a list (string, vector, bit
1735     vector).  If `across-ref' is given, VAR is bound using
1736     `symbol-macrolet' instead of `let' -- see above.
1737
1738   for VAR being each/the element/elements in/of/in-ref/of-ref SEQUENCE [using (index INDEX-VAR)]
1739     Step VAR across any sequence.  A variable can be specified with a
1740     `using' phrase to receive the index, starting at 0.  If `in-ref' or
1741     `of-ref' is given, VAR is bound using `symbol-macrolet' instead of
1742     `let' -- see above.
1743
1744   for VAR being each/the hash-key/hash-keys/hash-value/hash-values in/of HASH-TABLE [using (hash-value/hash-key OTHER-VAR)]
1745
1746   for VAR being each/the hash-key/hash-keys/hash-value/hash-values in/of HASH-TABLE [using (hash-value/hash-key OTHER-VAR)]
1747     Map VAR over a hash table.  The various keywords are synonymous except
1748     those that distinguish between keys and values.  The `using' phrase is
1749     optional and allows both key and value to be bound.
1750
1751   for VAR being each/the symbol/present-symbol/external-symbol/symbols/present-symbols/external-symbols in/of OBARRAY
1752     Map VAR over the symbols in an obarray.  All symbol keywords are
1753     currently synonymous.
1754
1755   for VAR being each/the extent/extents [in/of BUFFER-OR-STRING] [from POS] [to POS]
1756     Map VAR over the extents in a buffer or string, defaulting to the
1757     current buffer, the beginning and the end, respectively.
1758
1759   for VAR being each/the interval/intervals [in/of BUFFER-OR-STRING] [property PROPERTY] [from POS] [to POS]
1760     Map VAR over the intervals without property change in a buffer or
1761     string, defaulting to the current buffer, the beginning and the end,
1762     respectively.  If PROPERTY is given, iteration occurs using
1763     `next-single-property-change'; otherwise, using
1764     `next-property-change'.
1765
1766   for VAR being each/the window/windows [in/of FRAME]
1767     Step VAR over the windows in FRAME, defaulting to the selected frame.
1768
1769   for VAR being each/the frame/frames
1770     Step VAR over all frames.
1771
1772   for VAR being each/the buffer/buffers [by FUNC]
1773     Step VAR over all buffers.  This is actually equivalent to
1774     `for VAR in (buffer-list) [by FUNC]'.
1775
1776   for VAR being each/the key-code/key-codes/key-seq/key-seqs/key-binding/key-bindings in KEYMAP [using (key-code/key-codes/key-seq/key-seqs/key-binding/key-bindings OTHER-VAR)]
1777     Map VAR over the entries in a keymap.  Keyword `key-seq' causes
1778     recursive mapping over prefix keymaps occurring in the keymap, with VAR
1779     getting the built-up sequence (a vector).  Otherwise, mapping does not
1780     occur recursively.  `key-code' and `key-seq' refer to what is bound
1781     (second argument of `define-key'), and `key-binding' what it's bound to
1782     (third argument of `define-key').
1783
1784   as VAR ...
1785     `as' is a synonym for `for'.
1786
1787   and VAR ...
1788     `and' clauses have the same syntax as `for' clauses except that the
1789     variables in the clause are bound in parallel with a preceding
1790     `and'/`for' clause instead of in series.
1791
1792   with VAR = INIT
1793     Set VAR to INIT once, before doing any iterations.
1794
1795   repeat NUM
1796     Exit the loop if more than NUM iterations have occurred.
1797
1798   while COND
1799     Exit the loop if COND isn't true.
1800
1801   until COND
1802     Exit the loop if COND is true.
1803
1804   collect EXPR [into VAR]
1805     Push EXPR onto the end of a list of values -- stored either in VAR or a
1806     temporary variable that will be returned as the return value of the
1807     loop if it terminates through an exit condition or a call to
1808     `loop-finish'.
1809
1810   append EXPR [into VAR]
1811     Append EXPR (a list) onto the end of a list of values, like `collect'.
1812
1813   nconc EXPR [into VAR]
1814     Nconc EXPR (a list) onto the end of a list of values, like `collect'.
1815
1816   concat EXPR [into VAR]
1817     Concatenate EXPR (a string) onto the end of a string of values, like
1818     `collect'.
1819
1820   vconcat EXPR [into VAR]
1821     Concatenate EXPR (a vector) onto the end of a vector of values, like
1822     `collect'.
1823
1824   bvconcat EXPR [into VAR]
1825     Concatenate EXPR (a bit vector) onto the end of a bit vector of values,
1826     like `collect'.
1827
1828   sum EXPR [into VAR]
1829     Add EXPR to a value, like `collect'.
1830
1831   count EXPR [into VAR]
1832     If EXPR is true, increment a value by 1, like `collect'.
1833
1834   maximize EXPR [into VAR]
1835     IF EXPR is greater than a value, replace the value with EXPR, like
1836     `collect'.
1837
1838   minimize EXPR [into VAR]
1839     IF EXPR is less than a value, replace the value with EXPR, like
1840     `collect'.
1841
1842   always COND
1843     If COND is true, continue the loop and set the loop return value (the
1844     same value that's manipulated by `collect' and friends and is returned
1845     by a normal loop exit or an exit using `loop-finish') to t; otherwise,
1846     exit the loop and return nil.  The effect is to determine and return
1847     whether a condition is true "always" (all iterations of the loop).
1848
1849   never COND
1850     If COND is false, continue the loop and set the loop return value (like
1851     `always') to t; otherwise, exit the loop and return nil.  The effect
1852     is to determine and return whether a condition is "never" true (all
1853     iterations of the loop).
1854
1855   thereis COND
1856     If COND is true, exit the loop and return COND.
1857
1858   if/when COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...]
1859     If COND is true, execute the directly following clause(s); otherwise,
1860     execute the clauses following `else'.
1861
1862   unless COND CLAUSE [and CLAUSE]... else CLAUSE [and CLAUSE...]
1863     If COND is false, execute the directly following clause(s); otherwise, execute the clauses following `else'.
1864
1865   do EXPRS...
1866     Execute the expressions (any Lisp forms).
1867
1868   initially EXPRS...
1869     Execute EXPR once, before doing any iterations, and after values have
1870     been set using `with'.
1871
1872   finally EXPRS...
1873     Execute EXPR once, directly before the loop terminates.  This will not
1874     be executed if the loop terminates prematurely as a result of `always',
1875     `never', `thereis', or `return'.
1876
1877   return EXPR
1878     Exit from the loop and return EXPR.
1879
1880   finally return EXPR
1881     Specify the value to be returned when the loop exits. (Unlike `return',
1882     this doesn't cause the loop to immediately exit; it will exit whenever
1883     it normally would have.) This takes precedence over a return value
1884     specified with `collect' and friends or `always' and friends.
1885
1886   named NAME
1887     Specify the name for block surrounding the loop, in place of nil.
1888     (See `block'.)
1889                                             */
1890       (args))
1891 {
1892         Lisp_Object loop_sentence = Qnil;
1893         Lisp_Object result = Qnil;
1894         struct gcpro gcpro1, gcpro2;
1895         cl_loop_sentence_t *lsen;
1896
1897         /* bullshit case */
1898         if (NILP(args)) {
1899                 while (1) {
1900                         QUIT;
1901                 }
1902                 return Qnil;
1903         }
1904
1905         GCPRO2(result, loop_sentence);
1906
1907         loop_sentence = Fcl_loop_sentence(args);
1908         lsen = get_dynacat(loop_sentence);
1909         result = cl_loop_perform(lsen);
1910
1911         UNGCPRO;
1912         return result;
1913 }
1914
1915 /* ###autoload */
1916 DEFUN("cl:do", Fcl_do, 2, UNEVALLED, 0, /*
1917 The Common Lisp `do' loop.
1918 Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)
1919 */
1920       (args))
1921 {
1922         /* This function can GC */
1923         Lisp_Object varform = XCAR(args);
1924         Lisp_Object endform = XCAR(XCDR(args));
1925         Lisp_Object body = XCDR(XCDR(args));
1926         Lisp_Object result = Qnil;
1927         Lisp_Object endtest = Qnil, resultform = Qnil;
1928         struct gcpro gcpro1, gcpro2;
1929         int speccount = specpdl_depth();
1930
1931         CHECK_CONS(varform);
1932         CHECK_CONS(endform);
1933
1934         GCPRO2(endtest, resultform);
1935
1936         endtest = XCAR(endform);
1937         resultform = XCDR(endform);
1938
1939         result = emodcl_do(
1940                 varform, endtest, resultform, body,
1941                 emodcl_initialise_vars, emodcl_step_vars);
1942
1943         unbind_to(speccount, Qnil);
1944         UNGCPRO;
1945         return result;
1946 }
1947
1948 /* ###autoload */
1949 DEFUN("cl:do*", Fcl_doX, 2, UNEVALLED, 0, /*
1950 The Common Lisp `do*' loop.
1951 Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)
1952 */
1953       (args))
1954 {
1955         /* This function can GC */
1956         Lisp_Object varform = XCAR(args);
1957         Lisp_Object endform = XCAR(XCDR(args));
1958         Lisp_Object body = XCDR(XCDR(args));
1959         Lisp_Object result = Qnil;
1960         Lisp_Object endtest = Qnil, resultform = Qnil;
1961         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1962         int speccount = specpdl_depth();
1963
1964         CHECK_CONS(varform);
1965         CHECK_CONS(endform);
1966
1967         GCPRO4(result, endtest, resultform, body);
1968
1969         endtest = XCAR(endform);
1970         resultform = XCDR(endform);
1971
1972         result = emodcl_do(
1973                 varform, endtest, resultform, body,
1974                 emodcl_initialise_vars_star, emodcl_step_vars_star);
1975
1976         unbind_to(speccount, Qnil);
1977         UNGCPRO;
1978         return result;
1979 }
1980
1981
1982 /* ###autoload */
1983
1984 DEFUN("cl:dotimes", Fcl_dotimes, 1, UNEVALLED, 0, /*
1985 The Common Lisp `dotimes' loop.
1986 Format is: (dotimes (VAR COUNT [RESULT]) BODY...)
1987
1988 Loop a certain number of times. Evaluate BODY with VAR bound to
1989 successive integers from 0, inclusive,to COUNT, exclusive.  Then
1990 evaluate RESULT to get return value, default nil.
1991                                                   */
1992       (args))
1993 {
1994         /* This function can GC */
1995         Lisp_Object varform = XCAR(args);
1996         Lisp_Object body = XCDR(args);
1997         Lisp_Object result = Qnil;
1998         Lisp_Object varsym = Qnil, varcnt = Qnil, resultform = Qnil;
1999         struct gcpro gcpro1, gcpro2, gcpro3;
2000         int speccount = specpdl_depth();
2001         size_t j;
2002
2003         CHECK_CONS(varform);
2004         CHECK_CONS(XCDR(varform));
2005         CHECK_SYMBOL(varsym = XCAR(varform));
2006
2007         GCPRO3(result, varform, body);
2008         CHECK_NATNUM(varcnt = Feval(XCAR(XCDR(varform))));
2009
2010         specbind(varsym, Qzero);
2011         for (j = 0; j < XUINT(varcnt); j++) {
2012                 Fset(varsym, make_int(j));
2013                 LIST_LOOP_2(form, body) {
2014                         Feval(form);
2015                 }
2016         }
2017
2018         if (!NILP(resultform = XCDR(XCDR(varform)))) {
2019                 LIST_LOOP_2(form, resultform) {
2020                         result = Feval(form);
2021                 }
2022         }
2023
2024         unbind_to(speccount, Qnil);
2025         UNGCPRO;
2026         return result;
2027 }
2028
2029 /* ###autoload */
2030 DEFUN("cl:dolist", Fcl_dolist, 1, UNEVALLED, 0, /*
2031 The Common Lisp `dolist' loop.
2032 Format is: (dolist (VAR LIST [RESULT]) BODY...)
2033 loop over a list.
2034 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
2035 Then evaluate RESULT to get return value, default nil.
2036                                                 */
2037       (args))
2038 {
2039         /* This function can GC */
2040         Lisp_Object varform = XCAR(args);
2041         Lisp_Object body = XCDR(args);
2042         Lisp_Object result = Qnil;
2043         Lisp_Object varsym = Qnil, list = Qnil, resultform = Qnil;
2044         struct gcpro gcpro1, gcpro2, gcpro3;
2045         int speccount = specpdl_depth();
2046
2047         CHECK_CONS(varform);
2048         CHECK_CONS(XCDR(varform));
2049         CHECK_SYMBOL(varsym = XCAR(varform));
2050
2051         GCPRO3(result, varform, body);
2052         list = Feval(XCAR(XCDR(varform)));
2053         if (!NILP(list)) {
2054                 CHECK_CONS(list);
2055         } else {
2056                 /* nothing to do */
2057                 goto get_result;
2058         }
2059
2060         specbind(varsym, Qnil);
2061         while (!NILP(list)) {
2062                 Fset(varsym, XCAR(list));
2063                 LIST_LOOP_2(form, body) {
2064                         Feval(form);
2065                 }
2066                 list = XCDR(list);
2067         }
2068
2069 get_result:
2070         if (!NILP(resultform = XCDR(XCDR(varform)))) {
2071                 LIST_LOOP_2(form, resultform) {
2072                         result = Feval(form);
2073                 }
2074         }
2075
2076         unbind_to(speccount, Qnil);
2077         UNGCPRO;
2078         return result;
2079 }
2080
2081 extern Lisp_Object check_obarray(Lisp_Object obarray);
2082 /* ###autoload */
2083 DEFUN("cl:do-symbols", Fcl_do_symbols, 1, UNEVALLED, 0, /*
2084 The Common Lisp `dolist' loop.
2085 Format is: (do-symbols (VAR [OBARRAY [RESULT]]) BODY...)
2086 loop over all symbols.
2087 Evaluate BODY with VAR bound to each interned symbol, or to each symbol
2088 from OBARRAY.
2089                                                         */
2090       (args))
2091 {
2092         /* This function can GC */
2093         Lisp_Object varform = XCAR(args);
2094         Lisp_Object body = XCDR(args);
2095         Lisp_Object result = Qnil;
2096         Lisp_Object varsym = Qnil, obarr = Qnil, resultform = Qnil;
2097         struct gcpro gcpro1, gcpro2, gcpro3;
2098         int speccount = specpdl_depth();
2099         REGISTER int j;
2100
2101         CHECK_CONS(varform);
2102         CHECK_SYMBOL(varsym = XCAR(varform));
2103
2104         GCPRO3(result, varform, body);
2105
2106         if (NILP(XCDR(varform))) {
2107                 obarr = Vobarray;
2108         } else {
2109                 CHECK_CONS(XCDR(varform));
2110                 obarr = Feval(XCAR(XCDR(varform)));
2111         }
2112         obarr = check_obarray(obarr);
2113
2114         specbind(varsym, Qnil);
2115         for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
2116                 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
2117                 if (SYMBOLP(tail))
2118                         while (1) {
2119                                 Lisp_Symbol *next;
2120                                 Fset(varsym, tail);
2121                                 LIST_LOOP_2(form, body) {
2122                                         Feval(form);
2123                                 }
2124                                 next = symbol_next(XSYMBOL(tail));
2125                                 if (!next)
2126                                         break;
2127                                 XSETSYMBOL(tail, next);
2128                         }
2129         }
2130
2131         if (!NILP(XCDR(varform)) &&
2132             !NILP(resultform = XCDR(XCDR(varform)))) {
2133                 LIST_LOOP_2(form, resultform) {
2134                         result = Feval(form);
2135                 }
2136         }
2137
2138         unbind_to(speccount, Qnil);
2139         UNGCPRO;
2140         return result;
2141 }
2142
2143 /* ###autoload */
2144 DEFUN("cl:do-all-symbols", Fcl_do_all_symbols, 1, UNEVALLED, 0, /*
2145 The Common Lisp `dolist' loop.
2146 Format is: (do-all-symbols (VAR [RESULT]) BODY...)
2147 */
2148       (args))
2149 {
2150         /* This function can GC */
2151         Lisp_Object varform = XCAR(args);
2152         Lisp_Object body = XCDR(args);
2153         Lisp_Object result = Qnil;
2154         Lisp_Object varsym = Qnil, obarr = Qnil, resultform = Qnil;
2155         struct gcpro gcpro1, gcpro2, gcpro3;
2156         int speccount = specpdl_depth();
2157         REGISTER int j;
2158
2159         CHECK_CONS(varform);
2160         CHECK_SYMBOL(varsym = XCAR(varform));
2161
2162         GCPRO3(result, varform, body);
2163
2164         obarr = Vobarray;
2165
2166         specbind(varsym, Qnil);
2167         for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
2168                 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
2169                 if (SYMBOLP(tail))
2170                         while (1) {
2171                                 Lisp_Symbol *next;
2172                                 Fset(varsym, tail);
2173                                 LIST_LOOP_2(form, body) {
2174                                         Feval(form);
2175                                 }
2176                                 next = symbol_next(XSYMBOL(tail));
2177                                 if (!next)
2178                                         break;
2179                                 XSETSYMBOL(tail, next);
2180                         }
2181         }
2182
2183         if (!NILP(resultform = XCDR(varform))) {
2184                 LIST_LOOP_2(form, resultform) {
2185                         result = Feval(form);
2186                 }
2187         }
2188
2189         unbind_to(speccount, Qnil);
2190         UNGCPRO;
2191         return result;
2192 }
2193
2194 \f
2195 /* simplified initialisation */
2196 void
2197 INIT(void)
2198 {
2199         DEFSUBR(Fcl_loop_sentence);
2200         DEFSUBR(Fcl_loop);
2201         DEFSUBR(Fcl_loopX);
2202         DEFSUBR(Fcl_do);
2203         DEFSUBR(Fcl_doX);
2204         DEFSUBR(Fcl_dotimes);
2205         DEFSUBR(Fcl_dolist);
2206         DEFSUBR(Fcl_do_symbols);
2207         DEFSUBR(Fcl_do_all_symbols);
2208
2209         DEFSYMBOL(Qcl_loop_sentence);
2210         DEFSYMBOL(Qcl_loop_sentence_p);
2211         DEFSYMBOL(Qcl_loop_for_clause);
2212         DEFSYMBOL(Qcl_loop_for_clause_p);
2213         DEFSYMBOL(Qcl_loop_do_clause);
2214         DEFSYMBOL(Qcl_loop_do_clause_p);
2215         DEFSYMBOL(Qcl_loop_with_clause);
2216         DEFSYMBOL(Qcl_loop_with_clause_p);
2217         DEFSYMBOL(Qcl_loop_repeat_clause);
2218         DEFSYMBOL(Qcl_loop_repeat_clause_p);
2219         DEFSYMBOL(Qcl_loop_append_clause);
2220         DEFSYMBOL(Qcl_loop_append_clause_p);
2221         DEFSYMBOL(Qcl_loop_collect_clause);
2222         DEFSYMBOL(Qcl_loop_collect_clause_p);
2223         DEFSYMBOL(Qcl_loop_nconc_clause);
2224         DEFSYMBOL(Qcl_loop_nconc_clause_p);
2225         DEFSYMBOL(Qcl_loop_return_clause);
2226         DEFSYMBOL(Qcl_loop_return_clause_p);
2227         DEFSYMBOL(Qcl_loop_finally_clause);
2228         DEFSYMBOL(Qcl_loop_finally_clause_p);
2229         DEFSYMBOL(Qcl_loop_initially_clause);
2230         DEFSYMBOL(Qcl_loop_initially_clause_p);
2231         DEFSYMBOL(Qcl_loop_count_clause);
2232         DEFSYMBOL(Qcl_loop_count_clause_p);
2233         DEFSYMBOL(Qcl_loop_sum_clause);
2234         DEFSYMBOL(Qcl_loop_sum_clause_p);
2235         DEFSYMBOL(Qcl_loop_minimise_clause);
2236         DEFSYMBOL(Qcl_loop_minimise_clause_p);
2237         DEFSYMBOL(Qcl_loop_maximise_clause);
2238         DEFSYMBOL(Qcl_loop_maximise_clause_p);
2239
2240         DEFSYMBOL(Qfor);
2241         DEFSYMBOL(Qas);
2242         DEFSYMBOL(Qfrom);
2243         DEFSYMBOL(Qdownfrom);
2244         DEFSYMBOL(Qupfrom);
2245         DEFSYMBOL(Qto);
2246         DEFSYMBOL(Qdownto);
2247         DEFSYMBOL(Qupto);
2248         DEFSYMBOL(Qabove);
2249         DEFSYMBOL(Qbelow);
2250         DEFSYMBOL(Qby);
2251         DEFSYMBOL(Qin);
2252         DEFSYMBOL(Qon);
2253         DEFSYMBOL(Qthen);
2254         DEFSYMBOL(Qacross);
2255         DEFSYMBOL(Qeach);
2256         DEFSYMBOL(Qthe);
2257         DEFSYMBOL(Qbeing);
2258         DEFSYMBOL(Qhash_key);
2259         DEFSYMBOL(Qhash_keys);
2260         DEFSYMBOL(Qhash_value);
2261         DEFSYMBOL(Qhash_values);
2262         DEFSYMBOL(Qof);
2263         DEFSYMBOL(Qusing);
2264
2265         DEFSYMBOL(Qand);
2266         DEFSYMBOL(Qwith);
2267         defsymbol(&Qequals, "=");
2268
2269         DEFSYMBOL(Qappend);
2270         DEFSYMBOL(Qappending);
2271         DEFSYMBOL(Qcollect);
2272         DEFSYMBOL(Qcollecting);
2273         DEFSYMBOL(Qnconc);
2274         DEFSYMBOL(Qnconcing);
2275         DEFSYMBOL(Qinto);
2276         DEFSYMBOL(Qcount);
2277         DEFSYMBOL(Qcount);
2278         DEFSYMBOL(Qsum);
2279         DEFSYMBOL(Qsumming);
2280         DEFSYMBOL(Qmaximise);
2281         DEFSYMBOL(Qmaximising);
2282         DEFSYMBOL(Qmaximize);
2283         DEFSYMBOL(Qmaximizing);
2284         DEFSYMBOL(Qminimise);
2285         DEFSYMBOL(Qminimising);
2286         DEFSYMBOL(Qminimize);
2287         DEFSYMBOL(Qminimizing);
2288
2289         DEFSYMBOL(Qrepeat);
2290
2291         DEFSYMBOL(Qdo);
2292         DEFSYMBOL(Qdoing);
2293
2294         DEFSYMBOL(Qinitially);
2295         DEFSYMBOL(Qfinally);
2296
2297         DEFSYMBOL(Qanon_acn);
2298
2299         Fprovide(intern("cl-loop"));
2300 }
2301
2302 void
2303 DEINIT(void)
2304 {
2305         Frevoke(intern("cl-loop"));
2306 }
2307
2308 /* cl-loop.c ends here */