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
  44 #if !defined EMOD_CL_MONOMOD
  45 PROVIDE(cl_loop);
  46 REQUIRE(cl_loop, "cl");
  47 #endif
  48 #define INIT    cl_loop_LTX_init
  49 #define REINIT  cl_loop_LTX_reinit
  50 #define DEINIT  cl_loop_LTX_deinit
  51
  52 static inline int
  53 emodcl_initialise_vars(Lisp_Object varform)
  54         __attribute__((always_inline));
  55 static inline void
  56 emodcl_step_vars(Lisp_Object varform, int varcount)
  57         __attribute__((always_inline));
  58
  59 Lisp_Object Qcl_loop_sentence, Qcl_loop_sentence_p;
  60 Lisp_Object Qcl_loop_for_clause, Qcl_loop_for_clause_p;
  61 Lisp_Object Qcl_loop_do_clause, Qcl_loop_do_clause_p;
  62 Lisp_Object Qcl_loop_with_clause, Qcl_loop_with_clause_p;
  63 Lisp_Object Qcl_loop_repeat_clause, Qcl_loop_repeat_clause_p;
  64 Lisp_Object Qcl_loop_append_clause, Qcl_loop_append_clause_p;
  65 Lisp_Object Qcl_loop_collect_clause, Qcl_loop_collect_clause_p;
  66 Lisp_Object Qcl_loop_nconc_clause, Qcl_loop_nconc_clause_p;
  67 Lisp_Object Qcl_loop_return_clause, Qcl_loop_return_clause_p;
  68 Lisp_Object Qcl_loop_initially_clause, Qcl_loop_initially_clause_p;
  69 Lisp_Object Qcl_loop_finally_clause, Qcl_loop_finally_clause_p;
  70 Lisp_Object Qcl_loop_count_clause, Qcl_loop_count_clause_p;
  71 Lisp_Object Qcl_loop_sum_clause, Qcl_loop_sum_clause_p;
  72 Lisp_Object Qcl_loop_maximise_clause, Qcl_loop_maximise_clause_p;
  73 Lisp_Object Qcl_loop_minimise_clause, Qcl_loop_minimise_clause_p;
  74
  75 Lisp_Object Qfor, Qas;
  76 Lisp_Object Qfrom, Qdownfrom, Qupfrom, Qto, Qdownto, Qupto, Qabove, Qbelow, Qby;
  77 Lisp_Object Qin, Qon, Qthen, Qacross, Qeach, Qthe, Qbeing, Qof;
  78 Lisp_Object Qhash_key, Qhash_keys, Qhash_value, Qhash_values, Qusing;
  79 Lisp_Object Qdo, Qdoing;
  80 Lisp_Object Qtoken;
  81 Lisp_Object Qwith, Qequals, Qand;
  82 Lisp_Object Qrepeat;
  83 Lisp_Object Qappend, Qappending, Qcollect, Qcollecting, Qnconc, Qnconcing;
  84 Lisp_Object Qinto;
  85 Lisp_Object Qcount, Qcounting, Qsum, Qsumming;
  86 Lisp_Object Qmaximise, Qmaximising, Qmaximize, Qmaximizing;
  87 Lisp_Object Qminimise, Qminimising, Qminimize, Qminimizing;
  88 Lisp_Object Qinitially, Qfinally;
  89
  90 static Lisp_Object Qanon_acn;
  91
  92 \f
  93 static int
  94 emodcl_initialise_vars(Lisp_Object varform)
  95 {
  96         /* basically a let */
  97         int idx = 0;
  98         int varcount = 0;
  99
 100         /* Make space to hold the values to give the bound variables. */
 101         GET_EXTERNAL_LIST_LENGTH(varform, varcount);
 102
 103         {
 104                 Lisp_Object temps[varcount];
 105                 struct gcpro ngcpro1;
 106
 107                 /* wipe temps first */
 108                 memset(temps, 0, sizeof(Lisp_Object)*varcount);
 109
 110                 /* Compute the values and store them in `temps' */
 111                 NGCPROn(temps, varcount);
 112
 113                 LIST_LOOP_2(var, varform) {
 114                         Lisp_Object *value = &temps[idx++];
 115                         if (SYMBOLP(var))
 116                                 *value = Qnil;
 117                         else {
 118                                 Lisp_Object tem;
 119                                 CHECK_CONS(var);
 120                                 tem = XCDR(var);
 121                                 if (NILP(tem))
 122                                         *value = Qnil;
 123                                 else {
 124                                         CHECK_CONS(tem);
 125                                         *value = Feval(XCAR(tem));
 126                                 }
 127                         }
 128                 }
 129
 130                 idx = 0;
 131
 132                 LIST_LOOP_2(var, varform) {
 133                         specbind(SYMBOLP(var) ? var : XCAR(var), temps[idx++]);
 134                 }
 135
 136                 NUNGCPRO;
 137         }
 138
 139         return varcount;
 140 }
 141
 142 static void
 143 emodcl_step_vars(Lisp_Object varform, int varcount)
 144 {
 145         /* basically a let */
 146         Lisp_Object temps[varcount];
 147         struct gcpro ngcpro1;
 148         int idx = 0;
 149
 150         /* wipe temps first */
 151         memset(temps, 0, sizeof(Lisp_Object)*varcount);
 152
 153         /* Compute the values and store them in `temps' */
 154         NGCPROn(temps, varcount);
 155
 156         LIST_LOOP_2(var, varform) {
 157                 Lisp_Object *value = &temps[idx++];
 158                 Lisp_Object tmp;
 159                 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
 160                     !NILP(XCDR(tmp))) {
 161                         /* only if there is a step form of course */
 162                         *value = Feval(XCAR(XCDR(tmp)));
 163                 }
 164         }
 165
 166         idx = 0;
 167         LIST_LOOP_2(var, varform) {
 168                 Fset(XCAR(var), temps[idx++]);
 169         }
 170
 171         NUNGCPRO;
 172         return;
 173 }
 174
 175 static int
 176 emodcl_initialise_vars_star(Lisp_Object varform)
 177 {
 178         /* basically a let* */
 179         EXTERNAL_LIST_LOOP_3(var, varform, tail) {
 180                 Lisp_Object symbol, value, tem;
 181                 if (SYMBOLP(var))
 182                         symbol = var, value = Qnil;
 183                 else {
 184                         CHECK_CONS(var);
 185                         symbol = XCAR(var);
 186                         tem = XCDR(var);
 187                         if (NILP(tem))
 188                                 value = Qnil;
 189                         else {
 190                                 CHECK_CONS(tem);
 191                                 value = Feval(XCAR(tem));
 192                         }
 193                 }
 194                 specbind(symbol, value);
 195         }
 196         return 0;
 197 }
 198
 199 static void
 200 emodcl_step_vars_star(Lisp_Object varform, int unused)
 201 {
 202         EXTERNAL_LIST_LOOP_3(var, varform, tail) {
 203                 Lisp_Object symbol, value, tmp;
 204                 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
 205                     !NILP(XCDR(tmp))) {
 206                         /* only if there is a step form of course */
 207                         symbol = XCAR(var);
 208                         value = Feval(XCAR(XCDR(tmp)));
 209                         Fset(symbol, value);
 210                 }
 211         }
 212         return;
 213 }
 214
 215 static inline Lisp_Object
 216 emodcl_do_obtain_result(Lisp_Object resultform)
 217 {
 218         /* assumes that resultform is gc-protected already */
 219         Lisp_Object result = Qnil;
 220
 221         LIST_LOOP_2(form, resultform) {
 222                 result = Feval(form);
 223         }
 224
 225         return result;
 226 }
 227
 228 static Lisp_Object
 229 emodcl_do(
 230         Lisp_Object varform, Lisp_Object endtest, Lisp_Object resultform,
 231         Lisp_Object body,
 232         int(*initialiser)(Lisp_Object), void(*stepper)(Lisp_Object, int))
 233 {
 234         Lisp_Object result = Qnil;
 235         int numbervars = 0;
 236
 237         /* initial assignment */
 238         numbervars = initialiser(varform);
 239
 240         /* now loop */
 241         while (NILP(Feval(endtest))) {
 242 #if 1
 243                 LIST_LOOP_2(form, body) {
 244                         Feval(form);
 245                 }
 246 #else
 247                 internal_catch(tag, Fprogn, body, 0);
 248 #endif
 249                 /* evaluate step forms */
 250                 stepper(varform, numbervars);
 251         }
 252
 253         /* obtain a result */
 254         result = emodcl_do_obtain_result(resultform);
 255         return result;
 256 }
 257
 258 \f
 259 /* dynacat magic */
 260 static void
 261 cl_loop_sentence_mark(Lisp_Object obj)
 262 {
 263         cl_loop_sentence_t *lsen = get_dynacat(obj);
 264
 265         EMOD_CL_DEBUG_LOOP("sentence:0x%x@0x%x shall be marked...\n",
 266                            (unsigned int)(lsen), (unsigned int)obj);
 267
 268         mark_object(lsen->prologue);
 269         mark_object(lsen->epilogue);
 270         mark_object(lsen->iteration);
 271
 272         mark_object(lsen->result);
 273         return;
 274 }
 275
 276 static void
 277 cl_loop_for_clause_mark(Lisp_Object obj)
 278 {
 279         cl_loop_for_clause_t *fc = get_dynacat(obj);
 280
 281         EMOD_CL_DEBUG_LOOP("FOR:0x%x@0x%x shall be marked...\n",
 282                            (unsigned int)(fc), (unsigned int)obj);
 283
 284         mark_object(fc->form1);
 285         mark_object(fc->from);
 286         mark_object(fc->to);
 287         mark_object(fc->by);
 288
 289         mark_object(fc->inonacross);
 290
 291         mark_object(fc->equals);
 292         mark_object(fc->then);
 293
 294         mark_object(fc->hash_keyvar);
 295         mark_object(fc->hash_valvar);
 296
 297         mark_object(fc->curval);
 298         mark_object(fc->curbound);
 299         mark_object(fc->curstep);
 300         return;
 301 }
 302
 303 static void
 304 cl_loop_do_clause_mark(Lisp_Object obj)
 305 {
 306         cl_loop_do_clause_t *doc = get_dynacat(obj);
 307
 308         EMOD_CL_DEBUG_LOOP("DO:0x%x@0x%x shall be marked...\n",
 309                            (unsigned int)(doc), (unsigned int)obj);
 310
 311         mark_object(doc->form);
 312         return;
 313 }
 314
 315 static void
 316 cl_loop_with_clause_mark(Lisp_Object obj)
 317 {
 318         cl_loop_with_clause_t *wc = get_dynacat(obj);
 319
 320         EMOD_CL_DEBUG_LOOP("WITH:0x%x@0x%x shall be marked...\n",
 321                            (unsigned int)(wc), (unsigned int)obj);
 322
 323         mark_object(wc->varform);
 324         mark_object(wc->valform);
 325         mark_object(wc->next);
 326         return;
 327 }
 328
 329 static void
 330 cl_loop_repeat_clause_mark(Lisp_Object obj)
 331 {
 332         cl_loop_repeat_clause_t *rc = get_dynacat(obj);
 333
 334         EMOD_CL_DEBUG_LOOP("REPEAT:0x%x@0x%x shall be marked...\n",
 335                            (unsigned int)(rc), (unsigned int)obj);
 336
 337         mark_object(rc->form);
 338         return;
 339 }
 340
 341 static void
 342 cl_loop_inifinret_clause_mark(Lisp_Object obj)
 343 {
 344         cl_loop_inifinret_clause_t *rc = get_dynacat(obj);
 345
 346         EMOD_CL_DEBUG_LOOP("RETURN|INITIALLY|FINALLY:"
 347                            "0x%x@0x%x shall be marked...\n",
 348                            (unsigned int)(rc), (unsigned int)obj);
 349
 350         mark_object(rc->form);
 351         return;
 352 }
 353
 354 static void
 355 cl_loop_accu_clause_mark(Lisp_Object obj)
 356 {
 357         cl_loop_accu_clause_t *ac = get_dynacat(obj);
 358
 359         EMOD_CL_DEBUG_LOOP("ACCU(=COLLECT|APPEND|NCONC|etc.):"
 360                            "0x%x@0x%x shall be marked...\n",
 361                            (unsigned int)(ac), (unsigned int)obj);
 362
 363         mark_object(ac->form);
 364         mark_object(ac->into);
 365         mark_object(ac->cur);
 366         return;
 367 }
 368
 369 static void
 370 cl_loop_generic_finaliser(Lisp_Object obj, int SXE_UNUSED(for_disksave))
 371 {
 372         void *free_me = get_dynacat(obj);
 373
 374         EMOD_CL_DEBUG_LOOP("generic:%p@%p shall be freed\n",
 375                            free_me, (void*)obj);
 376
 377         xfree(free_me);
 378         set_dynacat(obj, NULL);
 379         return;
 380 }
 381
 382 \f
 383 /* auxiliary stuff */
 384 typedef void(*cl_loop_binder_f)(Lisp_Object, Lisp_Object);
 385
 386 static int
 387 cl_loop_destructuring_bind(
 388         cl_loop_binder_f bindfun, Lisp_Object form, Lisp_Object value)
 389 {
 390         Lisp_Object tmpf, tmpv;
 391         while (!NILP(form)) {
 392                 if (SYMBOLP(form)) {
 393                         bindfun(form, value);
 394                         return 1;
 395                 }
 396                 CHECK_CONS(form);
 397                 CHECK_CONS(value);
 398                 tmpf = XCAR(form);
 399                 tmpv = XCAR(value);
 400                 /* recursive approach? :| */
 401                 cl_loop_destructuring_bind(bindfun, tmpf, tmpv);
 402                 form = XCDR(form);
 403                 value = XCDR(value);
 404         }
 405         return 1;
 406 }
 407
 408 \f
 409 /* constructors */
 410 static inline Lisp_Object
 411 cl_loop_make_sentence(void)
 412 {
 413         cl_loop_sentence_t *lsen = xnew_and_zero(cl_loop_sentence_t);
 414         Lisp_Object result = make_dynacat(lsen);
 415
 416         set_dynacat_type(result, Qcl_loop_sentence);
 417
 418         XSETDLLIST(lsen->prologue, make_dllist());
 419         XSETDLLIST(lsen->epilogue, make_dllist());
 420         XSETDLLIST(lsen->iteration, make_dllist());
 421         lsen->state = 0;
 422         lsen->result = Qnil;
 423
 424         set_dynacat_marker(result, cl_loop_sentence_mark);
 425         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 426
 427         EMOD_CL_DEBUG_LOOP("sentence:0x%x shall be wrapped to 0x%x...\n",
 428                            (unsigned int)lsen, (unsigned int)result);
 429
 430         return result;
 431 }
 432
 433 Lisp_Object
 434 cl_loop_make_for_clause(Lisp_Object form1)
 435 {
 436         cl_loop_for_clause_t *fc = xnew_and_zero(cl_loop_for_clause_t);
 437         Lisp_Object result = make_dynacat(fc);
 438
 439         set_dynacat_type(result, Qcl_loop_for_clause);
 440
 441         fc->form1 = form1;
 442         fc->for_subclause = FOR_INVALID_CLAUSE;
 443
 444         /* arith subclause */
 445         fc->from = Qzero;
 446         fc->to = Qzero;
 447         fc->by = Qone;
 448         /* by default we increment and compare with equalp */
 449         fc->byop = ASE_BINARY_OP_SUM;
 450         fc->torel = ASE_BINARY_REL_LESSP;
 451         fc->torel_strictp = 0;
 452
 453         /* in/on subclauses */
 454         fc->inonacross = Qnil;
 455
 456         /* =-then */
 457         fc->equals = Qnil;
 458         fc->then = Qnil;
 459
 460         /* hash values */
 461         fc->hash_keyvar = Qnil;
 462         fc->hash_valvar = Qnil;
 463
 464         /* for parallel bind */
 465         fc->next = Qnil;
 466         fc->depth = 1;
 467
 468         /* for runtime */
 469         fc->curval = Qnil;
 470         fc->curbound = Qzero;
 471         fc->curstep = Qone;
 472         fc->counter = 0;
 473
 474         set_dynacat_marker(result, cl_loop_for_clause_mark);
 475         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 476
 477         EMOD_CL_DEBUG_LOOP("FOR:0x%x shall be wrapped to 0x%x...\n",
 478                            (unsigned int)fc, (unsigned int)result);
 479
 480         return result;
 481 }
 482
 483 Lisp_Object
 484 cl_loop_make_do_clause(Lisp_Object form1)
 485 {
 486         cl_loop_do_clause_t *doc = xnew_and_zero(cl_loop_do_clause_t);
 487         Lisp_Object result = make_dynacat(doc);
 488
 489         set_dynacat_type(result, Qcl_loop_do_clause);
 490
 491         doc->form = form1;
 492
 493         set_dynacat_marker(result, cl_loop_do_clause_mark);
 494         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 495
 496         EMOD_CL_DEBUG_LOOP("DO:0x%x shall be wrapped to 0x%x...\n",
 497                            (unsigned int)doc, (unsigned int)result);
 498
 499         return result;
 500 }
 501
 502 Lisp_Object
 503 cl_loop_make_repeat_clause(Lisp_Object form)
 504 {
 505         cl_loop_repeat_clause_t *rc = xnew_and_zero(cl_loop_repeat_clause_t);
 506         Lisp_Object result = make_dynacat(rc);
 507
 508         set_dynacat_type(result, Qcl_loop_repeat_clause);
 509
 510         rc->form = form;
 511         rc->counter = 0;
 512
 513         set_dynacat_marker(result, cl_loop_repeat_clause_mark);
 514         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 515
 516         EMOD_CL_DEBUG_LOOP("REPEAT:0x%x shall be wrapped to 0x%x...\n",
 517                            (unsigned int)rc, (unsigned int)result);
 518
 519         return result;
 520 }
 521
 522 Lisp_Object
 523 cl_loop_make_return_clause(Lisp_Object form)
 524 {
 525         cl_loop_inifinret_clause_t *rc =
 526                 xnew_and_zero(cl_loop_inifinret_clause_t);
 527         Lisp_Object result = make_dynacat(rc);
 528
 529         set_dynacat_type(result, Qcl_loop_return_clause);
 530
 531         rc->form = form;
 532
 533         set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
 534         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 535
 536         EMOD_CL_DEBUG_LOOP("RETURN:0x%x shall be wrapped to 0x%x...\n",
 537                            (unsigned int)rc, (unsigned int)result);
 538
 539         return result;
 540 }
 541
 542 Lisp_Object
 543 cl_loop_make_initially_clause(Lisp_Object form)
 544 {
 545         cl_loop_inifinret_clause_t *rc =
 546                 xnew_and_zero(cl_loop_inifinret_clause_t);
 547         Lisp_Object result = make_dynacat(rc);
 548
 549         set_dynacat_type(result, Qcl_loop_initially_clause);
 550
 551         rc->form = form;
 552
 553         set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
 554         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 555
 556         EMOD_CL_DEBUG_LOOP("INITIALLY:0x%x shall be wrapped to 0x%x...\n",
 557                            (unsigned int)rc, (unsigned int)result);
 558
 559         return result;
 560 }
 561
 562 Lisp_Object
 563 cl_loop_make_finally_clause(Lisp_Object form)
 564 {
 565         cl_loop_inifinret_clause_t *rc =
 566                 xnew_and_zero(cl_loop_inifinret_clause_t);
 567         Lisp_Object result = make_dynacat(rc);
 568
 569         set_dynacat_type(result, Qcl_loop_finally_clause);
 570
 571         rc->form = form;
 572
 573         set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
 574         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 575
 576         EMOD_CL_DEBUG_LOOP("FINALLY:0x%x shall be wrapped to 0x%x...\n",
 577                            (unsigned int)rc, (unsigned int)result);
 578
 579         return result;
 580 }
 581
 582 /* maybe a generic cl_loop_make_accu_clause? */
 583 Lisp_Object
 584 cl_loop_make_append_clause(Lisp_Object form)
 585 {
 586         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 587         Lisp_Object result = make_dynacat(ac);
 588
 589         set_dynacat_type(result, Qcl_loop_append_clause);
 590
 591         ac->form = form;
 592         ac->into = 0;
 593         ac->cur = 0;
 594
 595         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 596         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 597
 598         EMOD_CL_DEBUG_LOOP("APPEND:0x%x shall be wrapped to 0x%x...\n",
 599                            (unsigned int)ac, (unsigned int)result);
 600
 601         return result;
 602 }
 603
 604 Lisp_Object
 605 cl_loop_make_collect_clause(Lisp_Object form)
 606 {
 607         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 608         Lisp_Object result = make_dynacat(ac);
 609
 610         set_dynacat_type(result, Qcl_loop_collect_clause);
 611
 612         ac->form = form;
 613         ac->into = 0;
 614         ac->cur = 0;
 615
 616         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 617         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 618
 619         EMOD_CL_DEBUG_LOOP("COLLECT:0x%x shall be wrapped to 0x%x...\n",
 620                            (unsigned int)ac, (unsigned int)result);
 621
 622         return result;
 623 }
 624
 625 Lisp_Object
 626 cl_loop_make_nconc_clause(Lisp_Object form)
 627 {
 628         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 629         Lisp_Object result = make_dynacat(ac);
 630
 631         set_dynacat_type(result, Qcl_loop_nconc_clause);
 632
 633         ac->form = form;
 634         ac->into = 0;
 635         ac->cur = 0;
 636
 637         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 638         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 639
 640         EMOD_CL_DEBUG_LOOP("NCONC:0x%x shall be wrapped to 0x%x...\n",
 641                            (unsigned int)ac, (unsigned int)result);
 642
 643         return result;
 644 }
 645
 646 Lisp_Object
 647 cl_loop_make_count_clause(Lisp_Object form)
 648 {
 649         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 650         Lisp_Object result = make_dynacat(ac);
 651
 652         set_dynacat_type(result, Qcl_loop_count_clause);
 653
 654         ac->form = form;
 655         ac->into = 0;
 656         ac->cur = 0;
 657
 658         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 659         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 660
 661         EMOD_CL_DEBUG_LOOP("COUNT:0x%x shall be wrapped to 0x%x...\n",
 662                            (unsigned int)ac, (unsigned int)result);
 663
 664         return result;
 665 }
 666
 667 Lisp_Object
 668 cl_loop_make_sum_clause(Lisp_Object form)
 669 {
 670         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 671         Lisp_Object result = make_dynacat(ac);
 672
 673         set_dynacat_type(result, Qcl_loop_sum_clause);
 674
 675         ac->form = form;
 676         ac->into = 0;
 677         ac->cur = 0;
 678
 679         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 680         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 681
 682         EMOD_CL_DEBUG_LOOP("SUM:0x%x shall be wrapped to 0x%x...\n",
 683                            (unsigned int)ac, (unsigned int)result);
 684
 685         return result;
 686 }
 687
 688 Lisp_Object
 689 cl_loop_make_maximise_clause(Lisp_Object form)
 690 {
 691         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 692         Lisp_Object result = make_dynacat(ac);
 693
 694         set_dynacat_type(result, Qcl_loop_maximise_clause);
 695
 696         ac->form = form;
 697         ac->into = 0;
 698         ac->cur = 0;
 699
 700         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 701         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 702
 703         EMOD_CL_DEBUG_LOOP("MAXIMISE:0x%x shall be wrapped to 0x%x...\n",
 704                            (unsigned int)ac, (unsigned int)result);
 705
 706         return result;
 707 }
 708
 709 Lisp_Object
 710 cl_loop_make_minimise_clause(Lisp_Object form)
 711 {
 712         cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
 713         Lisp_Object result = make_dynacat(ac);
 714
 715         set_dynacat_type(result, Qcl_loop_minimise_clause);
 716
 717         ac->form = form;
 718         ac->into = 0;
 719         ac->cur = 0;
 720
 721         set_dynacat_marker(result, cl_loop_accu_clause_mark);
 722         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 723
 724         EMOD_CL_DEBUG_LOOP("MINIMISE:0x%x shall be wrapped to 0x%x...\n",
 725                            (unsigned int)ac, (unsigned int)result);
 726
 727         return result;
 728 }
 729
 730 Lisp_Object
 731 cl_loop_make_with_clause(Lisp_Object form)
 732 {
 733         cl_loop_with_clause_t *wc = xnew_and_zero(cl_loop_with_clause_t);
 734         Lisp_Object result = make_dynacat(wc);
 735
 736         set_dynacat_type(result, Qcl_loop_with_clause);
 737
 738         wc->varform = form;
 739         wc->valform = Qnil;
 740         wc->next = Qnil;
 741         wc->depth = 1;
 742
 743         set_dynacat_marker(result, cl_loop_with_clause_mark);
 744         set_dynacat_finaliser(result, cl_loop_generic_finaliser);
 745
 746         EMOD_CL_DEBUG_LOOP("WITH:0x%x shall be wrapped to 0x%x...\n",
 747                            (unsigned int)wc, (unsigned int)result);
 748
 749         return result;
 750 }
 751
 752 \f
 753 int
 754 cl_loop_yylex(YYSTYPE *yys, Lisp_Object *scanner,
 755               cl_loop_sentence_t *lsen, Lisp_Object *ctx, Lisp_Object *token)
 756 {
 757         Lisp_Object tok;
 758
 759         if (NILP(*scanner))
 760                 return *yys = 0;
 761
 762         tok = *token = XCAR(*scanner);
 763         *scanner = XCDR(*scanner);
 764
 765         if (EQ(tok, Qrepeat)) {
 766                 return *yys = REPEAT;
 767         }
 768         if (EQ(tok, Qfor) || EQ(tok, Qas)) {
 769                 return *yys = FOR;
 770         }
 771         if (EQ(tok, Qdo) || EQ(tok, Qdoing)) {
 772                 return *yys = DO;
 773         }
 774         if (EQ(tok, Qwith)) {
 775                 return *yys = WITH;
 776         }
 777         if (EQ(tok, Qand)) {
 778                 return *yys = AND;
 779         }
 780
 781         if (EQ(tok, Qfrom) ||
 782             EQ(tok, Qdownfrom) ||
 783             EQ(tok, Qupfrom)) {
 784                 return *yys = FROM;
 785         }
 786         if (EQ(tok, Qto) ||
 787             EQ(tok, Qdownto) ||
 788             EQ(tok, Qupto)) {
 789                 return *yys = TO;
 790         }
 791         if (EQ(tok, Qbelow)) {
 792                 return *yys = BELOW;
 793         }
 794         if (EQ(tok, Qabove)) {
 795                 return *yys = ABOVE;
 796         }
 797         if (EQ(tok, Qby)) {
 798                 return *yys = BY;
 799         }
 800         if (EQ(tok, Qin)) {
 801                 return *yys = IN;
 802         }
 803         if (EQ(tok, Qon)) {
 804                 return *yys = ON;
 805         }
 806         if (EQ(tok, Qequals)) {
 807                 return *yys = EQUALS;
 808         }
 809         if (EQ(tok, Qthen)) {
 810                 return *yys = THEN;
 811         }
 812         if (EQ(tok, Qacross)) {
 813                 return *yys = ACROSS;
 814         }
 815         if (EQ(tok, Qbeing)) {
 816                 return *yys = BEING;
 817         }
 818         if (EQ(tok, Qthe) || EQ(tok, Qeach)) {
 819                 return *yys = EACH;
 820         }
 821         if (EQ(tok, Qof) || EQ(tok, Qin)) {
 822                 return *yys = IN;
 823         }
 824         if (EQ(tok, Qhash_key) || EQ(tok, Qhash_keys)) {
 825                 return *yys = HASH_KEY;
 826         }
 827         if (EQ(tok, Qhash_value) || EQ(tok, Qhash_values)) {
 828                 return *yys = HASH_VALUE;
 829         }
 830         if (EQ(tok, Qusing)) {
 831                 return *yys = USING;
 832         }
 833         if (EQ(tok, Qcollect) || EQ(tok, Qcollecting)) {
 834                 return *yys = COLLECT;
 835         }
 836         if (EQ(tok, Qappend) || EQ(tok, Qappending)) {
 837                 return *yys = APPEND;
 838         }
 839         if (EQ(tok, Qnconc) || EQ(tok, Qnconcing)) {
 840                 return *yys = NCONC;
 841         }
 842         if (EQ(tok, Qcount) || EQ(tok, Qcount)) {
 843                 return *yys = COUNT;
 844         }
 845         if (EQ(tok, Qsum) || EQ(tok, Qsumming)) {
 846                 return *yys = SUM;
 847         }
 848         if (EQ(tok, Qminimise) || EQ(tok, Qminimising) ||
 849             EQ(tok, Qminimize) || EQ(tok, Qminimizing)) {
 850                 return *yys = MINIMISE;
 851         }
 852         if (EQ(tok, Qmaximise) || EQ(tok, Qmaximising) ||
 853             EQ(tok, Qmaximize) || EQ(tok, Qmaximizing)) {
 854                 return *yys = MAXIMISE;
 855         }
 856         if (EQ(tok, Qinto)) {
 857                 return *yys = INTO;
 858         }
 859         if (EQ(tok, Qinitially)) {
 860                 return *yys = INITIALLY;
 861         }
 862         if (EQ(tok, Qfinally)) {
 863                 return *yys = FINALLY;
 864         }
 865         if (EQ(tok, Qreturn)) {
 866                 return *yys = RETURN;
 867         }
 868
 869         return *yys = FORM;
 870 }
 871
 872 void
 873 cl_loop_yyerror(Lisp_Object *scanner, cl_loop_sentence_t *lsen,
 874                 Lisp_Object *ctx, Lisp_Object *token, char *msg)
 875 {
 876         Fsignal(Qinvalid_read_syntax, *scanner);
 877         return;
 878 }
 879
 880 \f
 881 static void
 882 cl_loop_perform_with_pro(cl_loop_with_clause_t *wc)
 883 {
 884         Lisp_Object val = Feval(wc->valform);
 885         if (wc->depth == 1) {
 886                 /* optimise for the trivial case */
 887                 cl_loop_destructuring_bind(specbind, wc->varform, val);
 888         } else {
 889                 Lisp_Object *tmp = alloca_array(Lisp_Object, wc->depth);
 890                 size_t i;
 891                 Lisp_Object tra;
 892
 893                 tmp[0] = val;
 894                 tra = wc->next;
 895                 for (i = 1; !NILP(tra); i++) {
 896                         cl_loop_with_clause_t *wct = get_dynacat(tra);
 897                         tmp[i] = Feval(wct->valform);
 898                         tra = wct->next;
 899                 }
 900
 901                 /* now specbind them */
 902                 cl_loop_destructuring_bind(specbind, wc->varform, tmp[0]);
 903                 tra = wc->next;
 904                 for (i = 1; !NILP(tra); i++) {
 905                         cl_loop_with_clause_t *wct = get_dynacat(tra);
 906                         cl_loop_destructuring_bind(
 907                                 specbind, wct->varform, tmp[i]);
 908                         tra = wct->next;
 909                 }
 910         }
 911 }
 912
 913 static inline void
 914 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
 915         __attribute__((always_inline));
 916 static inline void
 917 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
 918 {
 919         if (ac->into == Qnull_pointer) {
 920                 /* generate a random symbol */
 921                 ac->into = Qanon_acn;
 922         }
 923         specbind(ac->into, ac->cur = Qnil);
 924 }
 925
 926 static inline void
 927 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
 928         __attribute__((always_inline));
 929 static inline void
 930 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
 931 {
 932         if (ac->into == Qnull_pointer) {
 933                 /* generate a random symbol */
 934                 ac->into = Qanon_acn;
 935         }
 936         specbind(ac->into, ac->cur = Qzero);
 937 }
 938
 939 static inline void
 940 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
 941         __attribute__((always_inline));
 942 static inline void
 943 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
 944 {
 945         if (ac->into == Qnull_pointer) {
 946                 /* generate a random symbol */
 947                 ac->into = Qanon_acn;
 948         }
 949         specbind(ac->into, ac->cur = Vninfinity);
 950 }
 951
 952 static inline void
 953 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
 954         __attribute__((always_inline));
 955 static inline void
 956 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
 957 {
 958         if (ac->into == Qnull_pointer) {
 959                 /* generate a random symbol */
 960                 ac->into = Qanon_acn;
 961         }
 962         specbind(ac->into, ac->cur = Vpinfinity);
 963 }
 964
 965 static inline void
 966 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
 967         __attribute__((always_inline));
 968 static inline void
 969 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
 970 {
 971         Lisp_Object lctr = Feval(rc->form);
 972         CHECK_INT(lctr);
 973         rc->counter = XINT(lctr);
 974         return;
 975 }
 976
 977 static inline void
 978 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
 979         __attribute__((always_inline));
 980 static inline void
 981 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
 982 {
 983         Feval(rc->form);
 984         return;
 985 }
 986
 987 static hentry_t
 988 cl_loop_next_hentry(hentry_t e, const hash_table_t ht)
 989 {
 990         const hentry_t term = ht->hentries + ht->size;
 991         if (e == NULL) {
 992                 e = ht->hentries;
 993                 e--;
 994         }
 995
 996         while (e < term && HENTRY_CLEAR_P(++e));
 997
 998         if (e < term)
 999                 return e;
1000         else
1001                 return NULL;
1002 }
1003
1004 static void
1005 cl_loop_perform_for_pro_i(cl_loop_for_clause_t *fc)
1006 {
1007         switch (fc->for_subclause) {
1008         case FOR_ARITHMETIC_CLAUSE:
1009                 fc->curval = Feval(fc->from);
1010                 fc->curbound = Feval(fc->to);
1011                 fc->curstep = Feval(fc->by);
1012                 break;
1013         case FOR_IN_SUBLIST_CLAUSE:
1014                 fc->curbound = Feval(fc->inonacross);
1015                 /* error handling here, make sure curbound is a cons */
1016                 CHECK_CONS(fc->curbound);
1017                 fc->curval = XCAR(fc->curbound);
1018                 break;
1019         case FOR_ON_SUBLIST_CLAUSE:
1020                 fc->curbound = Feval(fc->inonacross);
1021                 CHECK_CONS(fc->curbound);
1022                 fc->curval = fc->curbound;
1023                 break;
1024         case FOR_ACROSS_ARRAY_CLAUSE:
1025                 fc->curbound = Feval(fc->inonacross);
1026                 fc->bound = XINT(Flength(fc->curbound));
1027                 /* CHECK_ARRAY(fc->curbound); */
1028                 fc->counter = 0;
1029                 fc->curval = Faref(fc->curbound, Qzero);
1030                 break;
1031         case FOR_EQUALS_THEN_CLAUSE:
1032                 fc->curval = Feval(fc->equals);
1033                 fc->counter = 0;
1034                 break;
1035         case FOR_OF_HASHTABLE_CLAUSE: {
1036                 hentry_t e;
1037                 fc->curbound = Feval(fc->inonacross);
1038                 e = cl_loop_next_hentry(
1039                         NULL, XHASH_TABLE(fc->curbound));
1040                 if ((fc->ptr1 = e) == NULL) {
1041                         return;
1042                 }
1043                 fc->curval = Qnil;
1044                 return;
1045         }
1046         case FOR_INVALID_CLAUSE:
1047         default:
1048                 /* there are `for' subclauses without stuff in the prologue */
1049                 break;
1050         }
1051         return;
1052 }
1053
1054 static void
1055 cl_loop_perform_for_pro_b(cl_loop_for_clause_t *fc)
1056 {
1057         switch (fc->for_subclause) {
1058         case FOR_ARITHMETIC_CLAUSE:
1059         case FOR_IN_SUBLIST_CLAUSE:
1060         case FOR_ON_SUBLIST_CLAUSE:
1061         case FOR_ACROSS_ARRAY_CLAUSE:
1062         case FOR_EQUALS_THEN_CLAUSE:
1063                 cl_loop_destructuring_bind(specbind, fc->form1, fc->curval);
1064                 break;
1065
1066         case FOR_OF_HASHTABLE_CLAUSE: {
1067                 hentry_t e = fc->ptr1;
1068                 if (e == NULL) {
1069                         return;
1070                 }
1071                 if (!NILP(fc->hash_keyvar)) {
1072                         cl_loop_destructuring_bind(
1073                                 specbind, fc->hash_keyvar, e->key);
1074                 }
1075                 if (!NILP(fc->hash_valvar)) {
1076                         cl_loop_destructuring_bind(
1077                                 specbind, fc->hash_valvar, e->value);
1078                 }
1079                 return;
1080         }
1081         case FOR_INVALID_CLAUSE:
1082         default:
1083                 /* there are `for' subclauses without stuff in the prologue */
1084                 break;
1085         }
1086         return;
1087 }
1088
1089 static void
1090 cl_loop_perform_for_pro(cl_loop_for_clause_t *fc)
1091 {
1092         if (fc->depth == 1) {
1093                 /* optimise for the trivial case */
1094                 cl_loop_perform_for_pro_i(fc);
1095                 cl_loop_perform_for_pro_b(fc);
1096                 return;
1097         } else {
1098                 Lisp_Object tra;
1099
1100                 cl_loop_perform_for_pro_i(fc);
1101                 tra = fc->next;
1102                 while (!NILP(tra)) {
1103                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1104                         cl_loop_perform_for_pro_i(fct);
1105                         tra = fct->next;
1106                 }
1107
1108                 /* now specbind them */
1109                 cl_loop_perform_for_pro_b(fc);
1110                 tra = fc->next;
1111                 while (!NILP(tra)) {
1112                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1113                         cl_loop_perform_for_pro_b(fct);
1114                         tra = fct->next;
1115                 }
1116         }
1117 }
1118
1119 static void
1120 cl_loop_perform_for_i(cl_loop_for_clause_t *fc)
1121 {
1122         /* non stepping stuff */
1123         switch (fc->for_subclause) {
1124         case FOR_EQUALS_THEN_CLAUSE:
1125                 if (fc->counter++) {
1126                         cl_loop_destructuring_bind(
1127                                 (cl_loop_binder_f)Fset, fc->form1,
1128                                 fc->curval = Feval(fc->then));
1129                 }
1130                 return;
1131         case FOR_INVALID_CLAUSE:
1132         case FOR_ARITHMETIC_CLAUSE:
1133         case FOR_IN_SUBLIST_CLAUSE:
1134         case FOR_ON_SUBLIST_CLAUSE:
1135         case FOR_ACROSS_ARRAY_CLAUSE:
1136         case FOR_OF_HASHTABLE_CLAUSE:
1137         default:
1138                 break;
1139         }
1140         return;
1141 }
1142
1143 static int
1144 cl_loop_perform_for_b(cl_loop_for_clause_t *fc)
1145 {
1146         switch (fc->for_subclause) {
1147         case FOR_ARITHMETIC_CLAUSE:
1148         case FOR_IN_SUBLIST_CLAUSE:
1149         case FOR_ON_SUBLIST_CLAUSE:
1150         case FOR_ACROSS_ARRAY_CLAUSE:
1151                 /* bind to the value computed during the last iteration */
1152                 cl_loop_destructuring_bind(
1153                         (cl_loop_binder_f)Fset, fc->form1, fc->curval);
1154         case FOR_INVALID_CLAUSE:
1155         case FOR_OF_HASHTABLE_CLAUSE:
1156         case FOR_EQUALS_THEN_CLAUSE:
1157         default:
1158                 break;
1159         }
1160
1161         /* most clauses step in this fun */
1162         switch (fc->for_subclause) {
1163         case FOR_EQUALS_THEN_CLAUSE:
1164                 return 1;
1165         case FOR_ARITHMETIC_CLAUSE:
1166                 fc->curval = ent_binop(fc->byop, fc->curval, fc->curstep);
1167                 if (!fc->torel_strictp) {
1168                         return ent_binrel2(fc->torel, ASE_BINARY_REL_EQUALP,
1169                                            fc->curval, fc->curbound);
1170                 } else {
1171                         return ent_binrel(fc->torel, fc->curval, fc->curbound);
1172                 }
1173                 break;
1174         case FOR_IN_SUBLIST_CLAUSE:
1175                 /* error handling here, make sure curbound is a cons */
1176                 fc->curbound = XCDR(fc->curbound);
1177                 if (NILP(fc->curbound))
1178                         return 0;
1179                 fc->curval = XCAR(fc->curbound);
1180                 return 1;
1181                 break;
1182         case FOR_ON_SUBLIST_CLAUSE:
1183                 /* error handling here, make sure curbound is a cons */
1184                 if (NILP(fc->curval = XCDR(fc->curval)))
1185                         return 0;
1186                 return 1;
1187                 break;
1188         case FOR_ACROSS_ARRAY_CLAUSE:
1189                 fc->counter++;
1190                 if (fc->counter >= fc->bound)
1191                         return 0;
1192                 fc->curval = Faref(fc->curbound, make_int(fc->counter));
1193                 return 1;
1194                 break;
1195         case FOR_OF_HASHTABLE_CLAUSE: {
1196                 hentry_t e = fc->ptr1;
1197                 if (e == NULL) {
1198                         return 0;
1199                 }
1200                 if (!NILP(fc->hash_keyvar)) {
1201                         cl_loop_destructuring_bind(
1202                                 (cl_loop_binder_f)Fset,
1203                                 fc->hash_keyvar, e->key);
1204                 }
1205                 if (!NILP(fc->hash_valvar)) {
1206                         cl_loop_destructuring_bind(
1207                                 (cl_loop_binder_f)Fset,
1208                                 fc->hash_valvar, e->value);
1209                 }
1210                 fc->ptr1 = cl_loop_next_hentry(e, XHASH_TABLE(fc->curbound));
1211                 return 1;
1212         }
1213         case FOR_INVALID_CLAUSE:
1214         default:
1215                 break;
1216         }
1217         return 1;
1218 }
1219
1220 static inline int
1221 cl_loop_perform_for(cl_loop_for_clause_t *fc)
1222 {
1223         if (fc->depth == 1) {
1224                 /* optimise for the trivial case */
1225                 cl_loop_perform_for_i(fc);
1226                 return cl_loop_perform_for_b(fc);
1227         } else {
1228                 Lisp_Object tra;
1229                 int state;
1230
1231                 cl_loop_perform_for_i(fc);
1232                 tra = fc->next;
1233                 while (!NILP(tra)) {
1234                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1235                         cl_loop_perform_for_i(fct);
1236                         tra = fct->next;
1237                 }
1238
1239                 /* now specbind them */
1240                 state = cl_loop_perform_for_b(fc);
1241                 tra = fc->next;
1242                 while (!NILP(tra)) {
1243                         cl_loop_for_clause_t *fct = get_dynacat(tra);
1244                         state &= cl_loop_perform_for_b(fct);
1245                         tra = fct->next;
1246                 }
1247                 return state;
1248         }
1249 }
1250
1251 static inline int
1252 cl_loop_perform_do(cl_loop_do_clause_t *dc)
1253 {
1254         Feval(dc->form);
1255         return 1;
1256 }
1257
1258 static inline int
1259 cl_loop_perform_repeat(cl_loop_repeat_clause_t *rc)
1260 {
1261         if (--rc->counter > 0) {
1262                 return 1;
1263         }
1264         return 0;
1265 }
1266
1267 static inline int
1268 cl_loop_perform_collect(cl_loop_accu_clause_t *ac)
1269 {
1270         if (!NILP(ac->cur))
1271                 ac->cur = XCDR(ac->cur) = Fcons(Feval(ac->form), Qnil);
1272         else {
1273                 Fset(ac->into, ac->cur = Fcons(Feval(ac->form), Qnil));
1274         }
1275         return 1;
1276 }
1277
1278 static inline int
1279 cl_loop_perform_append(cl_loop_accu_clause_t *ac)
1280 {
1281         Lisp_Object form = Feval(ac->form);
1282         CHECK_CONS(form);
1283         if (!NILP(ac->cur))
1284                 XCDR(ac->cur) = form;
1285         else {
1286                 Fset(ac->into, ac->cur = form);
1287         }
1288         while (!NILP(XCDR(ac->cur)) && CONSP(XCDR(ac->cur)))
1289                 ac->cur = XCDR(ac->cur);
1290         if (CONSP(ac->cur) && NILP(XCDR(ac->cur)))
1291                 return 1;
1292         else
1293                 return wrong_type_argument(Qlistp, form);
1294 }
1295
1296 static inline int
1297 cl_loop_perform_nconc(cl_loop_accu_clause_t *ac)
1298 {
1299         Lisp_Object form = Feval(ac->form);
1300         if (!NILP(ac->cur) && CONSP(ac->cur)) {
1301                 XCDR(ac->cur) = form;
1302         } else {
1303                 Fset(ac->into, ac->cur = form);
1304         }
1305         while (CONSP(ac->cur) &&
1306                !NILP(XCDR(ac->cur)) &&
1307                CONSP(XCDR(ac->cur)))
1308                 ac->cur = XCDR(ac->cur);
1309         return 1;
1310 }
1311
1312 static inline int
1313 cl_loop_perform_count(cl_loop_accu_clause_t *ac)
1314 {
1315         if (!NILP(Feval(ac->form))) {
1316                 Fset(ac->into, ac->cur = make_int(XINT(ac->cur)+1));
1317         }
1318         return 1;
1319 }
1320
1321 static inline int
1322 cl_loop_perform_sum(cl_loop_accu_clause_t *ac)
1323 {
1324         Lisp_Object form = Feval(ac->form);
1325         CHECK_NUMBER(form);
1326         Fset(ac->into,
1327              ac->cur = ent_binop(ASE_BINARY_OP_SUM, ac->cur, form));
1328         return 1;
1329 }
1330
1331 static inline int
1332 cl_loop_perform_maximise(cl_loop_accu_clause_t *ac)
1333 {
1334         Lisp_Object form = Feval(ac->form);
1335         CHECK_NUMBER(form);
1336         if (ent_binrel(ASE_BINARY_REL_GREATERP, form, ac->cur))
1337                 Fset(ac->into, ac->cur = form);
1338         return 1;
1339 }
1340
1341 static inline int
1342 cl_loop_perform_minimise(cl_loop_accu_clause_t *ac)
1343 {
1344         Lisp_Object form = Feval(ac->form);
1345         CHECK_NUMBER(form);
1346         if (ent_binrel(ASE_BINARY_REL_LESSP, form, ac->cur))
1347                 Fset(ac->into, ac->cur = form);
1348         return 1;
1349 }
1350
1351 static inline Lisp_Object
1352 cl_loop_perform_accu_epi()
1353         __attribute__((always_inline));
1354 static inline Lisp_Object
1355 cl_loop_perform_accu_epi(
1356         Lisp_Object *SXE_UNUSED(result), cl_loop_accu_clause_t *ac)
1357 {
1358         return symbol_value(XSYMBOL(ac->into));
1359 }
1360
1361 static inline Lisp_Object
1362 cl_loop_perform_finally_epi()
1363         __attribute__((always_inline));
1364 static inline Lisp_Object
1365 cl_loop_perform_finally_epi(
1366         Lisp_Object *SXE_UNUSED(result), cl_loop_inifinret_clause_t *rc)
1367 {
1368         return Feval(rc->form);
1369 }
1370
1371 static inline Lisp_Object
1372 cl_loop_perform_return_epi()
1373         __attribute__((always_inline));
1374 static inline Lisp_Object
1375 cl_loop_perform_return_epi(
1376         Lisp_Object *result, cl_loop_inifinret_clause_t *rc)
1377 {
1378         return *result = Feval(rc->form);
1379 }
1380
1381 \f
1382 static int
1383 cl_loop_prologue(Lisp_Object clause)
1384 {
1385         void *emp = NULL;
1386
1387         emp = get_dynacat(clause);
1388         if (EQ(get_dynacat_type(clause), Qcl_loop_repeat_clause)) {
1389                 cl_loop_perform_repeat_pro(emp);
1390                 return 1;
1391         }
1392         if (EQ(get_dynacat_type(clause), Qcl_loop_for_clause)) {
1393                 cl_loop_perform_for_pro(emp);
1394                 return 1;
1395         }
1396         if (EQ(get_dynacat_type(clause), Qcl_loop_with_clause)) {
1397                 cl_loop_perform_with_pro(emp);
1398                 return 1;
1399         }
1400         if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause)) {
1401                 cl_loop_perform_colappnco_pro(emp);
1402                 return 1;
1403         }
1404         if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1405                 cl_loop_perform_colappnco_pro(emp);
1406                 return 1;
1407         }
1408         if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1409                 cl_loop_perform_colappnco_pro(emp);
1410                 return 1;
1411         }
1412         if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1413                 cl_loop_perform_countsum_pro(emp);
1414                 return 1;
1415         }
1416         if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1417                 cl_loop_perform_countsum_pro(emp);
1418                 return 1;
1419         }
1420         if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1421                 cl_loop_perform_maximise_pro(emp);
1422                 return 1;
1423         }
1424         if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1425                 cl_loop_perform_minimise_pro(emp);
1426                 return 1;
1427         }
1428         if (EQ(get_dynacat_type(clause), Qcl_loop_initially_clause)) {
1429                 cl_loop_perform_initially_pro(emp);
1430                 return 1;
1431         }
1432
1433         return 1;
1434 }
1435
1436 static Lisp_Object
1437 cl_loop_epilogue(Lisp_Object *result, Lisp_Object clause)
1438 {
1439         void *emp = NULL;
1440
1441         emp = get_dynacat(clause);
1442         if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause)) {
1443                 return cl_loop_perform_accu_epi(result, emp);
1444         }
1445         if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1446                 return cl_loop_perform_accu_epi(result, emp);
1447         }
1448         if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1449                 return cl_loop_perform_accu_epi(result, emp);
1450         }
1451         if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1452                 return cl_loop_perform_accu_epi(result, emp);
1453         }
1454         if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1455                 return cl_loop_perform_accu_epi(result, emp);
1456         }
1457         if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1458                 return cl_loop_perform_accu_epi(result, emp);
1459         }
1460         if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1461                 return cl_loop_perform_accu_epi(result, emp);
1462         }
1463         if (EQ(get_dynacat_type(clause), Qcl_loop_return_clause)) {
1464                 return cl_loop_perform_return_epi(result, emp);
1465         }
1466         if (EQ(get_dynacat_type(clause), Qcl_loop_finally_clause)) {
1467                 return cl_loop_perform_finally_epi(result, emp);
1468         }
1469         return Qnull_pointer;
1470 }
1471
1472 static int
1473 cl_loop_iteration(Lisp_Object clause)
1474 {
1475         void *emp = NULL;
1476
1477         emp = get_dynacat(clause);
1478         if (EQ(get_dynacat_type(clause), Qcl_loop_repeat_clause))
1479                 return cl_loop_perform_repeat(emp);
1480         if (EQ(get_dynacat_type(clause), Qcl_loop_for_clause))
1481                 return cl_loop_perform_for(emp);
1482         if (EQ(get_dynacat_type(clause), Qcl_loop_do_clause))
1483                 return cl_loop_perform_do(emp);
1484         if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause))
1485                 return cl_loop_perform_collect(emp);
1486         if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause))
1487                 return cl_loop_perform_append(emp);
1488         if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause))
1489                 return cl_loop_perform_nconc(emp);
1490         if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause))
1491                 return cl_loop_perform_count(emp);
1492         if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause))
1493                 return cl_loop_perform_sum(emp);
1494         if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause))
1495                 return cl_loop_perform_maximise(emp);
1496         if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause))
1497                 return cl_loop_perform_minimise(emp);
1498
1499         return 0;
1500 }
1501
1502 static int
1503 cl_loop_dllist_map(int(*fun)(Lisp_Object), dllist_t dll)
1504 {
1505         int state;
1506         dllist_item_t item = dllist_first(dll);
1507
1508         if (item == NULL) {
1509                 return 0;
1510         }
1511
1512         state = 1;
1513         while (item) {
1514                 state &= fun((Lisp_Object)item->item);
1515                 item = item->next;
1516         }
1517         return state;
1518 }
1519
1520 static Lisp_Object
1521 cl_loop_dllist_map_return(
1522         Lisp_Object *result,
1523         Lisp_Object(*fun)(Lisp_Object*, Lisp_Object), dllist_t dll)
1524 {
1525         int state;
1526         dllist_item_t item = dllist_first(dll);
1527         Lisp_Object ret = Qnil;
1528
1529         if (item == NULL) {
1530                 return Qnil;
1531         }
1532
1533         state = 1;
1534         while (item) {
1535                 ret = fun(result, (Lisp_Object)item->item);
1536                 item = item->next;
1537         }
1538         if (!EQ(ret, Qnull_pointer))
1539                 return ret;
1540         else
1541                 return Qnil;
1542 }
1543
1544 static Lisp_Object
1545 cl_loop_perform(cl_loop_sentence_t *lsen)
1546 {
1547         dllist_t pro = XDLLIST(lsen->prologue);
1548         dllist_t epi = XDLLIST(lsen->epilogue);
1549         dllist_t iter = XDLLIST(lsen->iteration);
1550         int speccount = specpdl_depth();
1551         Lisp_Object res;
1552
1553         lsen->state = 1;
1554
1555         /* traverse the prologue */
1556         cl_loop_dllist_map(cl_loop_prologue, pro);
1557         /* traverse the iteration */
1558         while (lsen->state) {
1559                 QUIT;
1560                 lsen->state = cl_loop_dllist_map(cl_loop_iteration, iter);
1561         }
1562         /* traverse the epilogue */
1563         lsen->result = Qnull_pointer;
1564         res = cl_loop_dllist_map_return(&lsen->result, cl_loop_epilogue, epi);
1565
1566         unbind_to(speccount, Qnil);
1567         if (lsen->result)
1568                 return lsen->result;
1569         else
1570                 return res;
1571 }
1572
1573 \f
1574 /* ###autoload */
1575 DEFUN("cl:loop-sentence", Fcl_loop_sentence, 0, UNEVALLED, 0, /*
1576 The Common Lisp loop macro.
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
1591         UNGCPRO;
1592         return loop_sentence;
1593 }
1594
1595 DEFUN("cl:loop*", Fcl_loopX, 1, 1, 0, /*
1596 Execute LOOP-SENTENCE.
1597 */
1598       (loop_sentence))
1599 {
1600         Lisp_Object result = Qnil;
1601         struct gcpro gcpro1, gcpro2;
1602
1603         CHECK_CL_LOOP_SENTENCE(loop_sentence);
1604
1605         GCPRO2(result, loop_sentence);
1606
1607         result = cl_loop_perform(XCL_LOOP_SENTENCE(loop_sentence));
1608
1609         UNGCPRO;
1610         return result;
1611 }
1612
1613 DEFUN("cl:loop", Fcl_loop, 0, UNEVALLED, 0, /*
1614 The Common Lisp loop macro.
1615 */
1616       (args))
1617 {
1618         Lisp_Object loop_sentence = Qnil;
1619         Lisp_Object result = Qnil;
1620         struct gcpro gcpro1, gcpro2;
1621         cl_loop_sentence_t *lsen;
1622
1623         /* bullshit case */
1624         if (NILP(args)) {
1625                 while (1) {
1626                         QUIT;
1627                 }
1628                 return Qnil;
1629         }
1630
1631         GCPRO2(result, loop_sentence);
1632
1633         loop_sentence = Fcl_loop_sentence(args);
1634         lsen = get_dynacat(loop_sentence);
1635         result = cl_loop_perform(lsen);
1636
1637         UNGCPRO;
1638         return result;
1639 }
1640
1641 /* ###autoload */
1642 DEFUN("cl:do", Fcl_do, 2, UNEVALLED, 0, /*
1643 The Common Lisp `do' loop.
1644 Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)
1645 */
1646       (args))
1647 {
1648         /* This function can GC */
1649         Lisp_Object varform = XCAR(args);
1650         Lisp_Object endform = XCAR(XCDR(args));
1651         Lisp_Object body = XCDR(XCDR(args));
1652         Lisp_Object result = Qnil;
1653         Lisp_Object endtest = Qnil, resultform = Qnil;
1654         struct gcpro gcpro1, gcpro2;
1655         int speccount = specpdl_depth();
1656
1657         CHECK_CONS(varform);
1658         CHECK_CONS(endform);
1659
1660         GCPRO2(endtest, resultform);
1661
1662         endtest = XCAR(endform);
1663         resultform = XCDR(endform);
1664
1665         result = emodcl_do(
1666                 varform, endtest, resultform, body,
1667                 emodcl_initialise_vars, emodcl_step_vars);
1668
1669         unbind_to(speccount, Qnil);
1670         UNGCPRO;
1671         return result;
1672 }
1673
1674 /* ###autoload */
1675 DEFUN("cl:do*", Fcl_doX, 2, UNEVALLED, 0, /*
1676 The Common Lisp `do' loop.
1677 Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)
1678 */
1679       (args))
1680 {
1681         /* This function can GC */
1682         Lisp_Object varform = XCAR(args);
1683         Lisp_Object endform = XCAR(XCDR(args));
1684         Lisp_Object body = XCDR(XCDR(args));
1685         Lisp_Object result = Qnil;
1686         Lisp_Object endtest = Qnil, resultform = Qnil;
1687         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1688         int speccount = specpdl_depth();
1689
1690         CHECK_CONS(varform);
1691         CHECK_CONS(endform);
1692
1693         GCPRO4(result, endtest, resultform, body);
1694
1695         endtest = XCAR(endform);
1696         resultform = XCDR(endform);
1697
1698         result = emodcl_do(
1699                 varform, endtest, resultform, body,
1700                 emodcl_initialise_vars_star, emodcl_step_vars_star);
1701
1702         unbind_to(speccount, Qnil);
1703         UNGCPRO;
1704         return result;
1705 }
1706
1707
1708 /* ###autoload */
1709 DEFUN("cl:dotimes", Fcl_dotimes, 1, UNEVALLED, 0, /*
1710 The Common Lisp `dotimes' loop.
1711 Format is: (dotimes (VAR COUNT [RESULT]) BODY...)
1712 */
1713       (args))
1714 {
1715         /* This function can GC */
1716         Lisp_Object varform = XCAR(args);
1717         Lisp_Object body = XCDR(args);
1718         Lisp_Object result = Qnil;
1719         Lisp_Object varsym = Qnil, varcnt = Qnil, resultform = Qnil;
1720         struct gcpro gcpro1, gcpro2, gcpro3;
1721         int speccount = specpdl_depth();
1722         size_t j;
1723
1724         CHECK_CONS(varform);
1725         CHECK_CONS(XCDR(varform));
1726         CHECK_SYMBOL(varsym = XCAR(varform));
1727
1728         GCPRO3(result, varform, body);
1729         CHECK_NATNUM(varcnt = Feval(XCAR(XCDR(varform))));
1730
1731         specbind(varsym, Qzero);
1732         for (j = 0; j < XUINT(varcnt); j++) {
1733                 Fset(varsym, make_int(j));
1734                 LIST_LOOP_2(form, body) {
1735                         Feval(form);
1736                 }
1737         }
1738
1739         if (!NILP(resultform = XCDR(XCDR(varform)))) {
1740                 LIST_LOOP_2(form, resultform) {
1741                         result = Feval(form);
1742                 }
1743         }
1744
1745         unbind_to(speccount, Qnil);
1746         UNGCPRO;
1747         return result;
1748 }
1749
1750 /* ###autoload */
1751 DEFUN("cl:dolist", Fcl_dolist, 1, UNEVALLED, 0, /*
1752 The Common Lisp `dolist' loop.
1753 Format is: (dolist (VAR LIST [RESULT]) BODY...)
1754 */
1755       (args))
1756 {
1757         /* This function can GC */
1758         Lisp_Object varform = XCAR(args);
1759         Lisp_Object body = XCDR(args);
1760         Lisp_Object result = Qnil;
1761         Lisp_Object varsym = Qnil, list = Qnil, resultform = Qnil;
1762         struct gcpro gcpro1, gcpro2, gcpro3;
1763         int speccount = specpdl_depth();
1764
1765         CHECK_CONS(varform);
1766         CHECK_CONS(XCDR(varform));
1767         CHECK_SYMBOL(varsym = XCAR(varform));
1768
1769         GCPRO3(result, varform, body);
1770         list = Feval(XCAR(XCDR(varform)));
1771         if (!NILP(list)) {
1772                 CHECK_CONS(list);
1773         } else {
1774                 /* nothing to do */
1775                 goto get_result;
1776         }
1777
1778         specbind(varsym, Qnil);
1779         while (!NILP(list)) {
1780                 Fset(varsym, XCAR(list));
1781                 LIST_LOOP_2(form, body) {
1782                         Feval(form);
1783                 }
1784                 list = XCDR(list);
1785         }
1786
1787 get_result:
1788         if (!NILP(resultform = XCDR(XCDR(varform)))) {
1789                 LIST_LOOP_2(form, resultform) {
1790                         result = Feval(form);
1791                 }
1792         }
1793
1794         unbind_to(speccount, Qnil);
1795         UNGCPRO;
1796         return result;
1797 }
1798
1799 extern Lisp_Object check_obarray(Lisp_Object obarray);
1800 /* ###autoload */
1801 DEFUN("cl:do-symbols", Fcl_do_symbols, 1, UNEVALLED, 0, /*
1802 The Common Lisp `dolist' loop.
1803 Format is: (do-symbols (VAR [OBARRAY [RESULT]]) BODY...)
1804 */
1805       (args))
1806 {
1807         /* This function can GC */
1808         Lisp_Object varform = XCAR(args);
1809         Lisp_Object body = XCDR(args);
1810         Lisp_Object result = Qnil;
1811         Lisp_Object varsym = Qnil, obarr = Qnil, resultform = Qnil;
1812         struct gcpro gcpro1, gcpro2, gcpro3;
1813         int speccount = specpdl_depth();
1814         REGISTER int j;
1815
1816         CHECK_CONS(varform);
1817         CHECK_SYMBOL(varsym = XCAR(varform));
1818
1819         GCPRO3(result, varform, body);
1820
1821         if (NILP(XCDR(varform))) {
1822                 obarr = Vobarray;
1823         } else {
1824                 CHECK_CONS(XCDR(varform));
1825                 obarr = Feval(XCAR(XCDR(varform)));
1826         }
1827         obarr = check_obarray(obarr);
1828
1829         specbind(varsym, Qnil);
1830         for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
1831                 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
1832                 if (SYMBOLP(tail))
1833                         while (1) {
1834                                 Lisp_Symbol *next;
1835                                 Fset(varsym, tail);
1836                                 LIST_LOOP_2(form, body) {
1837                                         Feval(form);
1838                                 }
1839                                 next = symbol_next(XSYMBOL(tail));
1840                                 if (!next)
1841                                         break;
1842                                 XSETSYMBOL(tail, next);
1843                         }
1844         }
1845
1846         if (!NILP(XCDR(varform)) &&
1847             !NILP(resultform = XCDR(XCDR(varform)))) {
1848                 LIST_LOOP_2(form, resultform) {
1849                         result = Feval(form);
1850                 }
1851         }
1852
1853         unbind_to(speccount, Qnil);
1854         UNGCPRO;
1855         return result;
1856 }
1857
1858 /* ###autoload */
1859 DEFUN("cl:do-all-symbols", Fcl_do_all_symbols, 1, UNEVALLED, 0, /*
1860 The Common Lisp `dolist' loop.
1861 Format is: (do-all-symbols (VAR [RESULT]) BODY...)
1862 */
1863       (args))
1864 {
1865         /* This function can GC */
1866         Lisp_Object varform = XCAR(args);
1867         Lisp_Object body = XCDR(args);
1868         Lisp_Object result = Qnil;
1869         Lisp_Object varsym = Qnil, obarr = Qnil, resultform = Qnil;
1870         struct gcpro gcpro1, gcpro2, gcpro3;
1871         int speccount = specpdl_depth();
1872         REGISTER int j;
1873
1874         CHECK_CONS(varform);
1875         CHECK_SYMBOL(varsym = XCAR(varform));
1876
1877         GCPRO3(result, varform, body);
1878
1879         obarr = Vobarray;
1880
1881         specbind(varsym, Qnil);
1882         for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
1883                 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
1884                 if (SYMBOLP(tail))
1885                         while (1) {
1886                                 Lisp_Symbol *next;
1887                                 Fset(varsym, tail);
1888                                 LIST_LOOP_2(form, body) {
1889                                         Feval(form);
1890                                 }
1891                                 next = symbol_next(XSYMBOL(tail));
1892                                 if (!next)
1893                                         break;
1894                                 XSETSYMBOL(tail, next);
1895                         }
1896         }
1897
1898         if (!NILP(resultform = XCDR(varform))) {
1899                 LIST_LOOP_2(form, resultform) {
1900                         result = Feval(form);
1901                 }
1902         }
1903
1904         unbind_to(speccount, Qnil);
1905         UNGCPRO;
1906         return result;
1907 }
1908
1909 \f
1910 /* simplified initialisation */
1911 void
1912 INIT(void)
1913 {
1914         DEFSUBR(Fcl_loop_sentence);
1915         DEFSUBR(Fcl_loop);
1916         DEFSUBR(Fcl_loopX);
1917         DEFSUBR(Fcl_do);
1918         DEFSUBR(Fcl_doX);
1919         DEFSUBR(Fcl_dotimes);
1920         DEFSUBR(Fcl_dolist);
1921         DEFSUBR(Fcl_do_symbols);
1922         DEFSUBR(Fcl_do_all_symbols);
1923
1924         DEFSYMBOL(Qcl_loop_sentence);
1925         DEFSYMBOL(Qcl_loop_sentence_p);
1926         DEFSYMBOL(Qcl_loop_for_clause);
1927         DEFSYMBOL(Qcl_loop_for_clause_p);
1928         DEFSYMBOL(Qcl_loop_do_clause);
1929         DEFSYMBOL(Qcl_loop_do_clause_p);
1930         DEFSYMBOL(Qcl_loop_with_clause);
1931         DEFSYMBOL(Qcl_loop_with_clause_p);
1932         DEFSYMBOL(Qcl_loop_repeat_clause);
1933         DEFSYMBOL(Qcl_loop_repeat_clause_p);
1934         DEFSYMBOL(Qcl_loop_append_clause);
1935         DEFSYMBOL(Qcl_loop_append_clause_p);
1936         DEFSYMBOL(Qcl_loop_collect_clause);
1937         DEFSYMBOL(Qcl_loop_collect_clause_p);
1938         DEFSYMBOL(Qcl_loop_nconc_clause);
1939         DEFSYMBOL(Qcl_loop_nconc_clause_p);
1940         DEFSYMBOL(Qcl_loop_return_clause);
1941         DEFSYMBOL(Qcl_loop_return_clause_p);
1942         DEFSYMBOL(Qcl_loop_finally_clause);
1943         DEFSYMBOL(Qcl_loop_finally_clause_p);
1944         DEFSYMBOL(Qcl_loop_initially_clause);
1945         DEFSYMBOL(Qcl_loop_initially_clause_p);
1946         DEFSYMBOL(Qcl_loop_count_clause);
1947         DEFSYMBOL(Qcl_loop_count_clause_p);
1948         DEFSYMBOL(Qcl_loop_sum_clause);
1949         DEFSYMBOL(Qcl_loop_sum_clause_p);
1950         DEFSYMBOL(Qcl_loop_minimise_clause);
1951         DEFSYMBOL(Qcl_loop_minimise_clause_p);
1952         DEFSYMBOL(Qcl_loop_maximise_clause);
1953         DEFSYMBOL(Qcl_loop_maximise_clause_p);
1954
1955         DEFSYMBOL(Qfor);
1956         DEFSYMBOL(Qas);
1957         DEFSYMBOL(Qfrom);
1958         DEFSYMBOL(Qdownfrom);
1959         DEFSYMBOL(Qupfrom);
1960         DEFSYMBOL(Qto);
1961         DEFSYMBOL(Qdownto);
1962         DEFSYMBOL(Qupto);
1963         DEFSYMBOL(Qabove);
1964         DEFSYMBOL(Qbelow);
1965         DEFSYMBOL(Qby);
1966         DEFSYMBOL(Qin);
1967         DEFSYMBOL(Qon);
1968         DEFSYMBOL(Qthen);
1969         DEFSYMBOL(Qacross);
1970         DEFSYMBOL(Qeach);
1971         DEFSYMBOL(Qthe);
1972         DEFSYMBOL(Qbeing);
1973         DEFSYMBOL(Qhash_key);
1974         DEFSYMBOL(Qhash_keys);
1975         DEFSYMBOL(Qhash_value);
1976         DEFSYMBOL(Qhash_values);
1977         DEFSYMBOL(Qof);
1978         DEFSYMBOL(Qusing);
1979
1980         DEFSYMBOL(Qand);
1981         DEFSYMBOL(Qwith);
1982         defsymbol(&Qequals, "=");
1983
1984         DEFSYMBOL(Qappend);
1985         DEFSYMBOL(Qappending);
1986         DEFSYMBOL(Qcollect);
1987         DEFSYMBOL(Qcollecting);
1988         DEFSYMBOL(Qnconc);
1989         DEFSYMBOL(Qnconcing);
1990         DEFSYMBOL(Qinto);
1991         DEFSYMBOL(Qcount);
1992         DEFSYMBOL(Qcount);
1993         DEFSYMBOL(Qsum);
1994         DEFSYMBOL(Qsumming);
1995         DEFSYMBOL(Qmaximise);
1996         DEFSYMBOL(Qmaximising);
1997         DEFSYMBOL(Qmaximize);
1998         DEFSYMBOL(Qmaximizing);
1999         DEFSYMBOL(Qminimise);
2000         DEFSYMBOL(Qminimising);
2001         DEFSYMBOL(Qminimize);
2002         DEFSYMBOL(Qminimizing);
2003
2004         DEFSYMBOL(Qrepeat);
2005
2006         DEFSYMBOL(Qdo);
2007         DEFSYMBOL(Qdoing);
2008
2009         DEFSYMBOL(Qinitially);
2010         DEFSYMBOL(Qfinally);
2011
2012         DEFSYMBOL(Qanon_acn);
2013
2014         Fprovide(intern("cl-loop"));
2015 }
2016
2017 void
2018 DEINIT(void)
2019 {
2020         Frevoke(intern("cl-loop"));
2021 }
2022
2023 /* cl-loop.c ends here */