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         int state;
1527         dllist_item_t item = dllist_first(dll);
1528         Lisp_Object ret = Qnil;
1529
1530         if (item == NULL) {
1531                 return Qnil;
1532         }
1533
1534         state = 1;
1535         while (item) {
1536                 ret = fun(result, (Lisp_Object)item->item);
1537                 item = item->next;
1538         }
1539         if (!EQ(ret, Qnull_pointer))
1540                 return ret;
1541         else
1542                 return Qnil;
1543 }
1544
1545 static Lisp_Object
1546 cl_loop_perform(cl_loop_sentence_t *lsen)
1547 {
1548         dllist_t pro = XDLLIST(lsen->prologue);
1549         dllist_t epi = XDLLIST(lsen->epilogue);
1550         dllist_t iter = XDLLIST(lsen->iteration);
1551         int speccount = specpdl_depth();
1552         Lisp_Object res;
1553
1554         lsen->state = 1;
1555
1556         /* traverse the prologue */
1557         cl_loop_dllist_map(cl_loop_prologue, pro);
1558         /* traverse the iteration */
1559         while (lsen->state) {
1560                 QUIT;
1561                 lsen->state = cl_loop_dllist_map(cl_loop_iteration, iter);
1562         }
1563         /* traverse the epilogue */
1564         lsen->result = Qnull_pointer;
1565         res = cl_loop_dllist_map_return(&lsen->result, cl_loop_epilogue, epi);
1566
1567         unbind_to(speccount, Qnil);
1568         if (lsen->result)
1569                 return lsen->result;
1570         else
1571                 return res;
1572 }
1573
1574 \f
1575 /* ###autoload */
1576 DEFUN("cl:loop-sentence", Fcl_loop_sentence, 0, UNEVALLED, 0, /*
1577 The Common Lisp loop macro.
1578 */
1579       (args))
1580 {
1581         Lisp_Object loop_sentence = cl_loop_make_sentence();
1582         Lisp_Object context = Qnil, token = Qnil;
1583         cl_loop_sentence_t *lsen = get_dynacat(loop_sentence);
1584         int parse_result;
1585         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1586
1587         GCPRO4(args, loop_sentence, context, token);
1588
1589         /* now parse the stuff */
1590         parse_result = cl_loop_yyparse(&args, lsen, &context, &token);
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 The Common Lisp loop macro.
1616 */
1617       (args))
1618 {
1619         Lisp_Object loop_sentence = Qnil;
1620         Lisp_Object result = Qnil;
1621         struct gcpro gcpro1, gcpro2;
1622         cl_loop_sentence_t *lsen;
1623
1624         /* bullshit case */
1625         if (NILP(args)) {
1626                 while (1) {
1627                         QUIT;
1628                 }
1629                 return Qnil;
1630         }
1631
1632         GCPRO2(result, loop_sentence);
1633
1634         loop_sentence = Fcl_loop_sentence(args);
1635         lsen = get_dynacat(loop_sentence);
1636         result = cl_loop_perform(lsen);
1637
1638         UNGCPRO;
1639         return result;
1640 }
1641
1642 /* ###autoload */
1643 DEFUN("cl:do", Fcl_do, 2, UNEVALLED, 0, /*
1644 The Common Lisp `do' loop.
1645 Format is: (do ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)
1646 */
1647       (args))
1648 {
1649         /* This function can GC */
1650         Lisp_Object varform = XCAR(args);
1651         Lisp_Object endform = XCAR(XCDR(args));
1652         Lisp_Object body = XCDR(XCDR(args));
1653         Lisp_Object result = Qnil;
1654         Lisp_Object endtest = Qnil, resultform = Qnil;
1655         struct gcpro gcpro1, gcpro2;
1656         int speccount = specpdl_depth();
1657
1658         CHECK_CONS(varform);
1659         CHECK_CONS(endform);
1660
1661         GCPRO2(endtest, resultform);
1662
1663         endtest = XCAR(endform);
1664         resultform = XCDR(endform);
1665
1666         result = emodcl_do(
1667                 varform, endtest, resultform, body,
1668                 emodcl_initialise_vars, emodcl_step_vars);
1669
1670         unbind_to(speccount, Qnil);
1671         UNGCPRO;
1672         return result;
1673 }
1674
1675 /* ###autoload */
1676 DEFUN("cl:do*", Fcl_doX, 2, UNEVALLED, 0, /*
1677 The Common Lisp `do' loop.
1678 Format is: (do* ((VAR INIT [STEP])...) (END-TEST [RESULT...]) BODY...)
1679 */
1680       (args))
1681 {
1682         /* This function can GC */
1683         Lisp_Object varform = XCAR(args);
1684         Lisp_Object endform = XCAR(XCDR(args));
1685         Lisp_Object body = XCDR(XCDR(args));
1686         Lisp_Object result = Qnil;
1687         Lisp_Object endtest = Qnil, resultform = Qnil;
1688         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1689         int speccount = specpdl_depth();
1690
1691         CHECK_CONS(varform);
1692         CHECK_CONS(endform);
1693
1694         GCPRO4(result, endtest, resultform, body);
1695
1696         endtest = XCAR(endform);
1697         resultform = XCDR(endform);
1698
1699         result = emodcl_do(
1700                 varform, endtest, resultform, body,
1701                 emodcl_initialise_vars_star, emodcl_step_vars_star);
1702
1703         unbind_to(speccount, Qnil);
1704         UNGCPRO;
1705         return result;
1706 }
1707
1708
1709 /* ###autoload */
1710 DEFUN("cl:dotimes", Fcl_dotimes, 1, UNEVALLED, 0, /*
1711 The Common Lisp `dotimes' loop.
1712 Format is: (dotimes (VAR COUNT [RESULT]) BODY...)
1713 */
1714       (args))
1715 {
1716         /* This function can GC */
1717         Lisp_Object varform = XCAR(args);
1718         Lisp_Object body = XCDR(args);
1719         Lisp_Object result = Qnil;
1720         Lisp_Object varsym = Qnil, varcnt = Qnil, resultform = Qnil;
1721         struct gcpro gcpro1, gcpro2, gcpro3;
1722         int speccount = specpdl_depth();
1723         size_t j;
1724
1725         CHECK_CONS(varform);
1726         CHECK_CONS(XCDR(varform));
1727         CHECK_SYMBOL(varsym = XCAR(varform));
1728
1729         GCPRO3(result, varform, body);
1730         CHECK_NATNUM(varcnt = Feval(XCAR(XCDR(varform))));
1731
1732         specbind(varsym, Qzero);
1733         for (j = 0; j < XUINT(varcnt); j++) {
1734                 Fset(varsym, make_int(j));
1735                 LIST_LOOP_2(form, body) {
1736                         Feval(form);
1737                 }
1738         }
1739
1740         if (!NILP(resultform = XCDR(XCDR(varform)))) {
1741                 LIST_LOOP_2(form, resultform) {
1742                         result = Feval(form);
1743                 }
1744         }
1745
1746         unbind_to(speccount, Qnil);
1747         UNGCPRO;
1748         return result;
1749 }
1750
1751 /* ###autoload */
1752 DEFUN("cl:dolist", Fcl_dolist, 1, UNEVALLED, 0, /*
1753 The Common Lisp `dolist' loop.
1754 Format is: (dolist (VAR LIST [RESULT]) BODY...)
1755 */
1756       (args))
1757 {
1758         /* This function can GC */
1759         Lisp_Object varform = XCAR(args);
1760         Lisp_Object body = XCDR(args);
1761         Lisp_Object result = Qnil;
1762         Lisp_Object varsym = Qnil, list = Qnil, resultform = Qnil;
1763         struct gcpro gcpro1, gcpro2, gcpro3;
1764         int speccount = specpdl_depth();
1765
1766         CHECK_CONS(varform);
1767         CHECK_CONS(XCDR(varform));
1768         CHECK_SYMBOL(varsym = XCAR(varform));
1769
1770         GCPRO3(result, varform, body);
1771         list = Feval(XCAR(XCDR(varform)));
1772         if (!NILP(list)) {
1773                 CHECK_CONS(list);
1774         } else {
1775                 /* nothing to do */
1776                 goto get_result;
1777         }
1778
1779         specbind(varsym, Qnil);
1780         while (!NILP(list)) {
1781                 Fset(varsym, XCAR(list));
1782                 LIST_LOOP_2(form, body) {
1783                         Feval(form);
1784                 }
1785                 list = XCDR(list);
1786         }
1787
1788 get_result:
1789         if (!NILP(resultform = XCDR(XCDR(varform)))) {
1790                 LIST_LOOP_2(form, resultform) {
1791                         result = Feval(form);
1792                 }
1793         }
1794
1795         unbind_to(speccount, Qnil);
1796         UNGCPRO;
1797         return result;
1798 }
1799
1800 extern Lisp_Object check_obarray(Lisp_Object obarray);
1801 /* ###autoload */
1802 DEFUN("cl:do-symbols", Fcl_do_symbols, 1, UNEVALLED, 0, /*
1803 The Common Lisp `dolist' loop.
1804 Format is: (do-symbols (VAR [OBARRAY [RESULT]]) BODY...)
1805 */
1806       (args))
1807 {
1808         /* This function can GC */
1809         Lisp_Object varform = XCAR(args);
1810         Lisp_Object body = XCDR(args);
1811         Lisp_Object result = Qnil;
1812         Lisp_Object varsym = Qnil, obarr = Qnil, resultform = Qnil;
1813         struct gcpro gcpro1, gcpro2, gcpro3;
1814         int speccount = specpdl_depth();
1815         REGISTER int j;
1816
1817         CHECK_CONS(varform);
1818         CHECK_SYMBOL(varsym = XCAR(varform));
1819
1820         GCPRO3(result, varform, body);
1821
1822         if (NILP(XCDR(varform))) {
1823                 obarr = Vobarray;
1824         } else {
1825                 CHECK_CONS(XCDR(varform));
1826                 obarr = Feval(XCAR(XCDR(varform)));
1827         }
1828         obarr = check_obarray(obarr);
1829
1830         specbind(varsym, Qnil);
1831         for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
1832                 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
1833                 if (SYMBOLP(tail))
1834                         while (1) {
1835                                 Lisp_Symbol *next;
1836                                 Fset(varsym, tail);
1837                                 LIST_LOOP_2(form, body) {
1838                                         Feval(form);
1839                                 }
1840                                 next = symbol_next(XSYMBOL(tail));
1841                                 if (!next)
1842                                         break;
1843                                 XSETSYMBOL(tail, next);
1844                         }
1845         }
1846
1847         if (!NILP(XCDR(varform)) &&
1848             !NILP(resultform = XCDR(XCDR(varform)))) {
1849                 LIST_LOOP_2(form, resultform) {
1850                         result = Feval(form);
1851                 }
1852         }
1853
1854         unbind_to(speccount, Qnil);
1855         UNGCPRO;
1856         return result;
1857 }
1858
1859 /* ###autoload */
1860 DEFUN("cl:do-all-symbols", Fcl_do_all_symbols, 1, UNEVALLED, 0, /*
1861 The Common Lisp `dolist' loop.
1862 Format is: (do-all-symbols (VAR [RESULT]) BODY...)
1863 */
1864       (args))
1865 {
1866         /* This function can GC */
1867         Lisp_Object varform = XCAR(args);
1868         Lisp_Object body = XCDR(args);
1869         Lisp_Object result = Qnil;
1870         Lisp_Object varsym = Qnil, obarr = Qnil, resultform = Qnil;
1871         struct gcpro gcpro1, gcpro2, gcpro3;
1872         int speccount = specpdl_depth();
1873         REGISTER int j;
1874
1875         CHECK_CONS(varform);
1876         CHECK_SYMBOL(varsym = XCAR(varform));
1877
1878         GCPRO3(result, varform, body);
1879
1880         obarr = Vobarray;
1881
1882         specbind(varsym, Qnil);
1883         for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
1884                 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
1885                 if (SYMBOLP(tail))
1886                         while (1) {
1887                                 Lisp_Symbol *next;
1888                                 Fset(varsym, tail);
1889                                 LIST_LOOP_2(form, body) {
1890                                         Feval(form);
1891                                 }
1892                                 next = symbol_next(XSYMBOL(tail));
1893                                 if (!next)
1894                                         break;
1895                                 XSETSYMBOL(tail, next);
1896                         }
1897         }
1898
1899         if (!NILP(resultform = XCDR(varform))) {
1900                 LIST_LOOP_2(form, resultform) {
1901                         result = Feval(form);
1902                 }
1903         }
1904
1905         unbind_to(speccount, Qnil);
1906         UNGCPRO;
1907         return result;
1908 }
1909
1910 \f
1911 /* simplified initialisation */
1912 void
1913 INIT(void)
1914 {
1915         DEFSUBR(Fcl_loop_sentence);
1916         DEFSUBR(Fcl_loop);
1917         DEFSUBR(Fcl_loopX);
1918         DEFSUBR(Fcl_do);
1919         DEFSUBR(Fcl_doX);
1920         DEFSUBR(Fcl_dotimes);
1921         DEFSUBR(Fcl_dolist);
1922         DEFSUBR(Fcl_do_symbols);
1923         DEFSUBR(Fcl_do_all_symbols);
1924
1925         DEFSYMBOL(Qcl_loop_sentence);
1926         DEFSYMBOL(Qcl_loop_sentence_p);
1927         DEFSYMBOL(Qcl_loop_for_clause);
1928         DEFSYMBOL(Qcl_loop_for_clause_p);
1929         DEFSYMBOL(Qcl_loop_do_clause);
1930         DEFSYMBOL(Qcl_loop_do_clause_p);
1931         DEFSYMBOL(Qcl_loop_with_clause);
1932         DEFSYMBOL(Qcl_loop_with_clause_p);
1933         DEFSYMBOL(Qcl_loop_repeat_clause);
1934         DEFSYMBOL(Qcl_loop_repeat_clause_p);
1935         DEFSYMBOL(Qcl_loop_append_clause);
1936         DEFSYMBOL(Qcl_loop_append_clause_p);
1937         DEFSYMBOL(Qcl_loop_collect_clause);
1938         DEFSYMBOL(Qcl_loop_collect_clause_p);
1939         DEFSYMBOL(Qcl_loop_nconc_clause);
1940         DEFSYMBOL(Qcl_loop_nconc_clause_p);
1941         DEFSYMBOL(Qcl_loop_return_clause);
1942         DEFSYMBOL(Qcl_loop_return_clause_p);
1943         DEFSYMBOL(Qcl_loop_finally_clause);
1944         DEFSYMBOL(Qcl_loop_finally_clause_p);
1945         DEFSYMBOL(Qcl_loop_initially_clause);
1946         DEFSYMBOL(Qcl_loop_initially_clause_p);
1947         DEFSYMBOL(Qcl_loop_count_clause);
1948         DEFSYMBOL(Qcl_loop_count_clause_p);
1949         DEFSYMBOL(Qcl_loop_sum_clause);
1950         DEFSYMBOL(Qcl_loop_sum_clause_p);
1951         DEFSYMBOL(Qcl_loop_minimise_clause);
1952         DEFSYMBOL(Qcl_loop_minimise_clause_p);
1953         DEFSYMBOL(Qcl_loop_maximise_clause);
1954         DEFSYMBOL(Qcl_loop_maximise_clause_p);
1955
1956         DEFSYMBOL(Qfor);
1957         DEFSYMBOL(Qas);
1958         DEFSYMBOL(Qfrom);
1959         DEFSYMBOL(Qdownfrom);
1960         DEFSYMBOL(Qupfrom);
1961         DEFSYMBOL(Qto);
1962         DEFSYMBOL(Qdownto);
1963         DEFSYMBOL(Qupto);
1964         DEFSYMBOL(Qabove);
1965         DEFSYMBOL(Qbelow);
1966         DEFSYMBOL(Qby);
1967         DEFSYMBOL(Qin);
1968         DEFSYMBOL(Qon);
1969         DEFSYMBOL(Qthen);
1970         DEFSYMBOL(Qacross);
1971         DEFSYMBOL(Qeach);
1972         DEFSYMBOL(Qthe);
1973         DEFSYMBOL(Qbeing);
1974         DEFSYMBOL(Qhash_key);
1975         DEFSYMBOL(Qhash_keys);
1976         DEFSYMBOL(Qhash_value);
1977         DEFSYMBOL(Qhash_values);
1978         DEFSYMBOL(Qof);
1979         DEFSYMBOL(Qusing);
1980
1981         DEFSYMBOL(Qand);
1982         DEFSYMBOL(Qwith);
1983         defsymbol(&Qequals, "=");
1984
1985         DEFSYMBOL(Qappend);
1986         DEFSYMBOL(Qappending);
1987         DEFSYMBOL(Qcollect);
1988         DEFSYMBOL(Qcollecting);
1989         DEFSYMBOL(Qnconc);
1990         DEFSYMBOL(Qnconcing);
1991         DEFSYMBOL(Qinto);
1992         DEFSYMBOL(Qcount);
1993         DEFSYMBOL(Qcount);
1994         DEFSYMBOL(Qsum);
1995         DEFSYMBOL(Qsumming);
1996         DEFSYMBOL(Qmaximise);
1997         DEFSYMBOL(Qmaximising);
1998         DEFSYMBOL(Qmaximize);
1999         DEFSYMBOL(Qmaximizing);
2000         DEFSYMBOL(Qminimise);
2001         DEFSYMBOL(Qminimising);
2002         DEFSYMBOL(Qminimize);
2003         DEFSYMBOL(Qminimizing);
2004
2005         DEFSYMBOL(Qrepeat);
2006
2007         DEFSYMBOL(Qdo);
2008         DEFSYMBOL(Qdoing);
2009
2010         DEFSYMBOL(Qinitially);
2011         DEFSYMBOL(Qfinally);
2012
2013         DEFSYMBOL(Qanon_acn);
2014
2015         Fprovide(intern("cl-loop"));
2016 }
2017
2018 void
2019 DEINIT(void)
2020 {
2021         Frevoke(intern("cl-loop"));
2022 }
2023
2024 /* cl-loop.c ends here */