2 cl-loop.c -- Common Lisp Goodness, the fast version
3 Copyright (C) 2006, 2007 Sebastian Freundt
5 Author: Sebastian Freundt <hroptatyr@sxemacs.org>
7 * This file is part of SXEmacs.
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions
13 * 1. Redistributions of source code must retain the above copyright
14 * notice, this list of conditions and the following disclaimer.
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.
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.
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.
37 /* Synched up with: Not in FSF. */
45 #if !defined EMOD_CL_MONOMOD
47 REQUIRE(cl_loop, "cl");
49 #define INIT cl_loop_LTX_init
50 #define REINIT cl_loop_LTX_reinit
51 #define DEINIT cl_loop_LTX_deinit
54 emodcl_initialise_vars(Lisp_Object varform)
55 __attribute__((always_inline));
57 emodcl_step_vars(Lisp_Object varform, int varcount)
58 __attribute__((always_inline));
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;
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;
82 Lisp_Object Qwith, Qequals, Qand;
84 Lisp_Object Qappend, Qappending, Qcollect, Qcollecting, Qnconc, Qnconcing;
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;
91 static Lisp_Object Qanon_acn;
95 emodcl_initialise_vars(Lisp_Object varform)
101 /* Make space to hold the values to give the bound variables. */
102 GET_EXTERNAL_LIST_LENGTH(varform, varcount);
105 Lisp_Object temps[varcount];
106 struct gcpro ngcpro1;
108 /* wipe temps first */
109 memset(temps, 0, sizeof(Lisp_Object)*varcount);
111 /* Compute the values and store them in `temps' */
112 NGCPROn(temps, varcount);
114 LIST_LOOP_2(var, varform) {
115 Lisp_Object *value = &temps[idx++];
126 *value = Feval(XCAR(tem));
133 LIST_LOOP_2(var, varform) {
134 specbind(SYMBOLP(var) ? var : XCAR(var), temps[idx++]);
144 emodcl_step_vars(Lisp_Object varform, int varcount)
146 /* basically a let */
147 Lisp_Object temps[varcount];
148 struct gcpro ngcpro1;
151 /* wipe temps first */
152 memset(temps, 0, sizeof(Lisp_Object)*varcount);
154 /* Compute the values and store them in `temps' */
155 NGCPROn(temps, varcount);
157 LIST_LOOP_2(var, varform) {
158 Lisp_Object *value = &temps[idx++];
160 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
162 /* only if there is a step form of course */
163 *value = Feval(XCAR(XCDR(tmp)));
168 LIST_LOOP_2(var, varform) {
169 Fset(XCAR(var), temps[idx++]);
177 emodcl_initialise_vars_star(Lisp_Object varform)
179 /* basically a let* */
180 EXTERNAL_LIST_LOOP_3(var, varform, tail) {
181 Lisp_Object symbol, value, tem;
183 symbol = var, value = Qnil;
192 value = Feval(XCAR(tem));
195 specbind(symbol, value);
201 emodcl_step_vars_star(Lisp_Object varform, int unused)
203 EXTERNAL_LIST_LOOP_3(var, varform, tail) {
204 Lisp_Object symbol, value, tmp;
205 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
207 /* only if there is a step form of course */
209 value = Feval(XCAR(XCDR(tmp)));
216 static inline Lisp_Object
217 emodcl_do_obtain_result(Lisp_Object resultform)
219 /* assumes that resultform is gc-protected already */
220 Lisp_Object result = Qnil;
222 LIST_LOOP_2(form, resultform) {
223 result = Feval(form);
231 Lisp_Object varform, Lisp_Object endtest, Lisp_Object resultform,
233 int(*initialiser)(Lisp_Object), void(*stepper)(Lisp_Object, int))
235 Lisp_Object result = Qnil;
238 /* initial assignment */
239 numbervars = initialiser(varform);
242 while (NILP(Feval(endtest))) {
244 LIST_LOOP_2(form, body) {
248 internal_catch(tag, Fprogn, body, 0);
250 /* evaluate step forms */
251 stepper(varform, numbervars);
254 /* obtain a result */
255 result = emodcl_do_obtain_result(resultform);
262 cl_loop_sentence_mark(Lisp_Object obj)
264 cl_loop_sentence_t *lsen = get_dynacat(obj);
266 EMOD_CL_DEBUG_LOOP("sentence:0x%x@0x%x shall be marked...\n",
267 (unsigned int)(lsen), (unsigned int)obj);
269 mark_object(lsen->prologue);
270 mark_object(lsen->epilogue);
271 mark_object(lsen->iteration);
273 mark_object(lsen->result);
278 cl_loop_for_clause_mark(Lisp_Object obj)
280 cl_loop_for_clause_t *fc = get_dynacat(obj);
282 EMOD_CL_DEBUG_LOOP("FOR:0x%x@0x%x shall be marked...\n",
283 (unsigned int)(fc), (unsigned int)obj);
285 mark_object(fc->form1);
286 mark_object(fc->from);
290 mark_object(fc->inonacross);
292 mark_object(fc->equals);
293 mark_object(fc->then);
295 mark_object(fc->hash_keyvar);
296 mark_object(fc->hash_valvar);
298 mark_object(fc->curval);
299 mark_object(fc->curbound);
300 mark_object(fc->curstep);
305 cl_loop_do_clause_mark(Lisp_Object obj)
307 cl_loop_do_clause_t *doc = get_dynacat(obj);
309 EMOD_CL_DEBUG_LOOP("DO:0x%x@0x%x shall be marked...\n",
310 (unsigned int)(doc), (unsigned int)obj);
312 mark_object(doc->form);
317 cl_loop_with_clause_mark(Lisp_Object obj)
319 cl_loop_with_clause_t *wc = get_dynacat(obj);
321 EMOD_CL_DEBUG_LOOP("WITH:0x%x@0x%x shall be marked...\n",
322 (unsigned int)(wc), (unsigned int)obj);
324 mark_object(wc->varform);
325 mark_object(wc->valform);
326 mark_object(wc->next);
331 cl_loop_repeat_clause_mark(Lisp_Object obj)
333 cl_loop_repeat_clause_t *rc = get_dynacat(obj);
335 EMOD_CL_DEBUG_LOOP("REPEAT:0x%x@0x%x shall be marked...\n",
336 (unsigned int)(rc), (unsigned int)obj);
338 mark_object(rc->form);
343 cl_loop_inifinret_clause_mark(Lisp_Object obj)
345 cl_loop_inifinret_clause_t *rc = get_dynacat(obj);
347 EMOD_CL_DEBUG_LOOP("RETURN|INITIALLY|FINALLY:"
348 "0x%x@0x%x shall be marked...\n",
349 (unsigned int)(rc), (unsigned int)obj);
351 mark_object(rc->form);
356 cl_loop_accu_clause_mark(Lisp_Object obj)
358 cl_loop_accu_clause_t *ac = get_dynacat(obj);
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);
364 mark_object(ac->form);
365 mark_object(ac->into);
366 mark_object(ac->cur);
371 cl_loop_generic_finaliser(Lisp_Object obj, int SXE_UNUSED(for_disksave))
373 void *free_me = get_dynacat(obj);
375 EMOD_CL_DEBUG_LOOP("generic:%p@%p shall be freed\n",
376 free_me, (void*)obj);
379 set_dynacat(obj, NULL);
384 /* auxiliary stuff */
385 typedef void(*cl_loop_binder_f)(Lisp_Object, Lisp_Object);
388 cl_loop_destructuring_bind(
389 cl_loop_binder_f bindfun, Lisp_Object form, Lisp_Object value)
391 Lisp_Object tmpf, tmpv;
392 while (!NILP(form)) {
394 bindfun(form, value);
401 /* recursive approach? :| */
402 cl_loop_destructuring_bind(bindfun, tmpf, tmpv);
411 static inline Lisp_Object
412 cl_loop_make_sentence(void)
414 cl_loop_sentence_t *lsen = xnew_and_zero(cl_loop_sentence_t);
415 Lisp_Object result = make_dynacat(lsen);
417 set_dynacat_type(result, Qcl_loop_sentence);
419 XSETDLLIST(lsen->prologue, make_dllist());
420 XSETDLLIST(lsen->epilogue, make_dllist());
421 XSETDLLIST(lsen->iteration, make_dllist());
425 set_dynacat_marker(result, cl_loop_sentence_mark);
426 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
428 EMOD_CL_DEBUG_LOOP("sentence:0x%x shall be wrapped to 0x%x...\n",
429 (unsigned int)lsen, (unsigned int)result);
435 cl_loop_make_for_clause(Lisp_Object form1)
437 cl_loop_for_clause_t *fc = xnew_and_zero(cl_loop_for_clause_t);
438 Lisp_Object result = make_dynacat(fc);
440 set_dynacat_type(result, Qcl_loop_for_clause);
443 fc->for_subclause = FOR_INVALID_CLAUSE;
445 /* arith subclause */
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;
454 /* in/on subclauses */
455 fc->inonacross = Qnil;
462 fc->hash_keyvar = Qnil;
463 fc->hash_valvar = Qnil;
465 /* for parallel bind */
471 fc->curbound = Qzero;
475 set_dynacat_marker(result, cl_loop_for_clause_mark);
476 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
478 EMOD_CL_DEBUG_LOOP("FOR:0x%x shall be wrapped to 0x%x...\n",
479 (unsigned int)fc, (unsigned int)result);
485 cl_loop_make_do_clause(Lisp_Object form1)
487 cl_loop_do_clause_t *doc = xnew_and_zero(cl_loop_do_clause_t);
488 Lisp_Object result = make_dynacat(doc);
490 set_dynacat_type(result, Qcl_loop_do_clause);
494 set_dynacat_marker(result, cl_loop_do_clause_mark);
495 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
497 EMOD_CL_DEBUG_LOOP("DO:0x%x shall be wrapped to 0x%x...\n",
498 (unsigned int)doc, (unsigned int)result);
504 cl_loop_make_repeat_clause(Lisp_Object form)
506 cl_loop_repeat_clause_t *rc = xnew_and_zero(cl_loop_repeat_clause_t);
507 Lisp_Object result = make_dynacat(rc);
509 set_dynacat_type(result, Qcl_loop_repeat_clause);
514 set_dynacat_marker(result, cl_loop_repeat_clause_mark);
515 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
517 EMOD_CL_DEBUG_LOOP("REPEAT:0x%x shall be wrapped to 0x%x...\n",
518 (unsigned int)rc, (unsigned int)result);
524 cl_loop_make_return_clause(Lisp_Object form)
526 cl_loop_inifinret_clause_t *rc =
527 xnew_and_zero(cl_loop_inifinret_clause_t);
528 Lisp_Object result = make_dynacat(rc);
530 set_dynacat_type(result, Qcl_loop_return_clause);
534 set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
535 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
537 EMOD_CL_DEBUG_LOOP("RETURN:0x%x shall be wrapped to 0x%x...\n",
538 (unsigned int)rc, (unsigned int)result);
544 cl_loop_make_initially_clause(Lisp_Object form)
546 cl_loop_inifinret_clause_t *rc =
547 xnew_and_zero(cl_loop_inifinret_clause_t);
548 Lisp_Object result = make_dynacat(rc);
550 set_dynacat_type(result, Qcl_loop_initially_clause);
554 set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
555 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
557 EMOD_CL_DEBUG_LOOP("INITIALLY:0x%x shall be wrapped to 0x%x...\n",
558 (unsigned int)rc, (unsigned int)result);
564 cl_loop_make_finally_clause(Lisp_Object form)
566 cl_loop_inifinret_clause_t *rc =
567 xnew_and_zero(cl_loop_inifinret_clause_t);
568 Lisp_Object result = make_dynacat(rc);
570 set_dynacat_type(result, Qcl_loop_finally_clause);
574 set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
575 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
577 EMOD_CL_DEBUG_LOOP("FINALLY:0x%x shall be wrapped to 0x%x...\n",
578 (unsigned int)rc, (unsigned int)result);
583 /* maybe a generic cl_loop_make_accu_clause? */
585 cl_loop_make_append_clause(Lisp_Object form)
587 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
588 Lisp_Object result = make_dynacat(ac);
590 set_dynacat_type(result, Qcl_loop_append_clause);
596 set_dynacat_marker(result, cl_loop_accu_clause_mark);
597 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
599 EMOD_CL_DEBUG_LOOP("APPEND:0x%x shall be wrapped to 0x%x...\n",
600 (unsigned int)ac, (unsigned int)result);
606 cl_loop_make_collect_clause(Lisp_Object form)
608 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
609 Lisp_Object result = make_dynacat(ac);
611 set_dynacat_type(result, Qcl_loop_collect_clause);
617 set_dynacat_marker(result, cl_loop_accu_clause_mark);
618 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
620 EMOD_CL_DEBUG_LOOP("COLLECT:0x%x shall be wrapped to 0x%x...\n",
621 (unsigned int)ac, (unsigned int)result);
627 cl_loop_make_nconc_clause(Lisp_Object form)
629 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
630 Lisp_Object result = make_dynacat(ac);
632 set_dynacat_type(result, Qcl_loop_nconc_clause);
638 set_dynacat_marker(result, cl_loop_accu_clause_mark);
639 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
641 EMOD_CL_DEBUG_LOOP("NCONC:0x%x shall be wrapped to 0x%x...\n",
642 (unsigned int)ac, (unsigned int)result);
648 cl_loop_make_count_clause(Lisp_Object form)
650 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
651 Lisp_Object result = make_dynacat(ac);
653 set_dynacat_type(result, Qcl_loop_count_clause);
659 set_dynacat_marker(result, cl_loop_accu_clause_mark);
660 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
662 EMOD_CL_DEBUG_LOOP("COUNT:0x%x shall be wrapped to 0x%x...\n",
663 (unsigned int)ac, (unsigned int)result);
669 cl_loop_make_sum_clause(Lisp_Object form)
671 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
672 Lisp_Object result = make_dynacat(ac);
674 set_dynacat_type(result, Qcl_loop_sum_clause);
680 set_dynacat_marker(result, cl_loop_accu_clause_mark);
681 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
683 EMOD_CL_DEBUG_LOOP("SUM:0x%x shall be wrapped to 0x%x...\n",
684 (unsigned int)ac, (unsigned int)result);
690 cl_loop_make_maximise_clause(Lisp_Object form)
692 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
693 Lisp_Object result = make_dynacat(ac);
695 set_dynacat_type(result, Qcl_loop_maximise_clause);
701 set_dynacat_marker(result, cl_loop_accu_clause_mark);
702 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
704 EMOD_CL_DEBUG_LOOP("MAXIMISE:0x%x shall be wrapped to 0x%x...\n",
705 (unsigned int)ac, (unsigned int)result);
711 cl_loop_make_minimise_clause(Lisp_Object form)
713 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
714 Lisp_Object result = make_dynacat(ac);
716 set_dynacat_type(result, Qcl_loop_minimise_clause);
722 set_dynacat_marker(result, cl_loop_accu_clause_mark);
723 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
725 EMOD_CL_DEBUG_LOOP("MINIMISE:0x%x shall be wrapped to 0x%x...\n",
726 (unsigned int)ac, (unsigned int)result);
732 cl_loop_make_with_clause(Lisp_Object form)
734 cl_loop_with_clause_t *wc = xnew_and_zero(cl_loop_with_clause_t);
735 Lisp_Object result = make_dynacat(wc);
737 set_dynacat_type(result, Qcl_loop_with_clause);
744 set_dynacat_marker(result, cl_loop_with_clause_mark);
745 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
747 EMOD_CL_DEBUG_LOOP("WITH:0x%x shall be wrapped to 0x%x...\n",
748 (unsigned int)wc, (unsigned int)result);
755 cl_loop_yylex(YYSTYPE *yys, Lisp_Object *scanner,
756 cl_loop_sentence_t *lsen, Lisp_Object *ctx, Lisp_Object *token)
763 tok = *token = XCAR(*scanner);
764 *scanner = XCDR(*scanner);
766 if (EQ(tok, Qrepeat)) {
767 return *yys = REPEAT;
769 if (EQ(tok, Qfor) || EQ(tok, Qas)) {
772 if (EQ(tok, Qdo) || EQ(tok, Qdoing)) {
775 if (EQ(tok, Qwith)) {
782 if (EQ(tok, Qfrom) ||
783 EQ(tok, Qdownfrom) ||
792 if (EQ(tok, Qbelow)) {
795 if (EQ(tok, Qabove)) {
807 if (EQ(tok, Qequals)) {
808 return *yys = EQUALS;
810 if (EQ(tok, Qthen)) {
813 if (EQ(tok, Qacross)) {
814 return *yys = ACROSS;
816 if (EQ(tok, Qbeing)) {
819 if (EQ(tok, Qthe) || EQ(tok, Qeach)) {
822 if (EQ(tok, Qof) || EQ(tok, Qin)) {
825 if (EQ(tok, Qhash_key) || EQ(tok, Qhash_keys)) {
826 return *yys = HASH_KEY;
828 if (EQ(tok, Qhash_value) || EQ(tok, Qhash_values)) {
829 return *yys = HASH_VALUE;
831 if (EQ(tok, Qusing)) {
834 if (EQ(tok, Qcollect) || EQ(tok, Qcollecting)) {
835 return *yys = COLLECT;
837 if (EQ(tok, Qappend) || EQ(tok, Qappending)) {
838 return *yys = APPEND;
840 if (EQ(tok, Qnconc) || EQ(tok, Qnconcing)) {
843 if (EQ(tok, Qcount) || EQ(tok, Qcount)) {
846 if (EQ(tok, Qsum) || EQ(tok, Qsumming)) {
849 if (EQ(tok, Qminimise) || EQ(tok, Qminimising) ||
850 EQ(tok, Qminimize) || EQ(tok, Qminimizing)) {
851 return *yys = MINIMISE;
853 if (EQ(tok, Qmaximise) || EQ(tok, Qmaximising) ||
854 EQ(tok, Qmaximize) || EQ(tok, Qmaximizing)) {
855 return *yys = MAXIMISE;
857 if (EQ(tok, Qinto)) {
860 if (EQ(tok, Qinitially)) {
861 return *yys = INITIALLY;
863 if (EQ(tok, Qfinally)) {
864 return *yys = FINALLY;
866 if (EQ(tok, Qreturn)) {
867 return *yys = RETURN;
874 cl_loop_yyerror(Lisp_Object *scanner, cl_loop_sentence_t *lsen,
875 Lisp_Object *ctx, Lisp_Object *token, char *msg)
877 Fsignal(Qinvalid_read_syntax, *scanner);
883 cl_loop_perform_with_pro(cl_loop_with_clause_t *wc)
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);
890 Lisp_Object *tmp = alloca_array(Lisp_Object, wc->depth);
896 for (i = 1; !NILP(tra); i++) {
897 cl_loop_with_clause_t *wct = get_dynacat(tra);
898 tmp[i] = Feval(wct->valform);
902 /* now specbind them */
903 cl_loop_destructuring_bind(specbind, wc->varform, tmp[0]);
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]);
915 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
916 __attribute__((always_inline));
918 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
920 if (ac->into == Qnull_pointer) {
921 /* generate a random symbol */
922 ac->into = Qanon_acn;
924 specbind(ac->into, ac->cur = Qnil);
928 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
929 __attribute__((always_inline));
931 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
933 if (ac->into == Qnull_pointer) {
934 /* generate a random symbol */
935 ac->into = Qanon_acn;
937 specbind(ac->into, ac->cur = Qzero);
941 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
942 __attribute__((always_inline));
944 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
946 if (ac->into == Qnull_pointer) {
947 /* generate a random symbol */
948 ac->into = Qanon_acn;
950 specbind(ac->into, ac->cur = Vninfinity);
954 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
955 __attribute__((always_inline));
957 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
959 if (ac->into == Qnull_pointer) {
960 /* generate a random symbol */
961 ac->into = Qanon_acn;
963 specbind(ac->into, ac->cur = Vpinfinity);
967 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
968 __attribute__((always_inline));
970 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
972 Lisp_Object lctr = Feval(rc->form);
974 rc->counter = XINT(lctr);
979 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
980 __attribute__((always_inline));
982 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
989 cl_loop_next_hentry(hentry_t e, const hash_table_t ht)
991 const hentry_t term = ht->hentries + ht->size;
997 while (e < term && HENTRY_CLEAR_P(++e));
1006 cl_loop_perform_for_pro_i(cl_loop_for_clause_t *fc)
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);
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);
1020 case FOR_ON_SUBLIST_CLAUSE:
1021 fc->curbound = Feval(fc->inonacross);
1022 CHECK_CONS(fc->curbound);
1023 fc->curval = fc->curbound;
1025 case FOR_ACROSS_ARRAY_CLAUSE:
1026 fc->curbound = Feval(fc->inonacross);
1027 fc->bound = XINT(Flength(fc->curbound));
1028 /* CHECK_ARRAY(fc->curbound); */
1030 fc->curval = Faref(fc->curbound, Qzero);
1032 case FOR_EQUALS_THEN_CLAUSE:
1033 fc->curval = Feval(fc->equals);
1036 case FOR_OF_HASHTABLE_CLAUSE: {
1038 fc->curbound = Feval(fc->inonacross);
1039 e = cl_loop_next_hentry(
1040 NULL, XHASH_TABLE(fc->curbound));
1041 if ((fc->ptr1 = e) == NULL) {
1047 case FOR_INVALID_CLAUSE:
1049 /* there are `for' subclauses without stuff in the prologue */
1056 cl_loop_perform_for_pro_b(cl_loop_for_clause_t *fc)
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);
1067 case FOR_OF_HASHTABLE_CLAUSE: {
1068 hentry_t e = fc->ptr1;
1072 if (!NILP(fc->hash_keyvar)) {
1073 cl_loop_destructuring_bind(
1074 specbind, fc->hash_keyvar, e->key);
1076 if (!NILP(fc->hash_valvar)) {
1077 cl_loop_destructuring_bind(
1078 specbind, fc->hash_valvar, e->value);
1082 case FOR_INVALID_CLAUSE:
1084 /* there are `for' subclauses without stuff in the prologue */
1091 cl_loop_perform_for_pro(cl_loop_for_clause_t *fc)
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);
1101 cl_loop_perform_for_pro_i(fc);
1103 while (!NILP(tra)) {
1104 cl_loop_for_clause_t *fct = get_dynacat(tra);
1105 cl_loop_perform_for_pro_i(fct);
1109 /* now specbind them */
1110 cl_loop_perform_for_pro_b(fc);
1112 while (!NILP(tra)) {
1113 cl_loop_for_clause_t *fct = get_dynacat(tra);
1114 cl_loop_perform_for_pro_b(fct);
1121 cl_loop_perform_for_i(cl_loop_for_clause_t *fc)
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));
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:
1145 cl_loop_perform_for_b(cl_loop_for_clause_t *fc)
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:
1162 /* most clauses step in this fun */
1163 switch (fc->for_subclause) {
1164 case FOR_EQUALS_THEN_CLAUSE:
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);
1172 return ent_binrel(fc->torel, fc->curval, fc->curbound);
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))
1180 fc->curval = XCAR(fc->curbound);
1183 case FOR_ON_SUBLIST_CLAUSE:
1184 /* error handling here, make sure curbound is a cons */
1185 if (NILP(fc->curval = XCDR(fc->curval)))
1189 case FOR_ACROSS_ARRAY_CLAUSE:
1191 if (fc->counter >= fc->bound)
1193 fc->curval = Faref(fc->curbound, make_int(fc->counter));
1196 case FOR_OF_HASHTABLE_CLAUSE: {
1197 hentry_t e = fc->ptr1;
1201 if (!NILP(fc->hash_keyvar)) {
1202 cl_loop_destructuring_bind(
1203 (cl_loop_binder_f)Fset,
1204 fc->hash_keyvar, e->key);
1206 if (!NILP(fc->hash_valvar)) {
1207 cl_loop_destructuring_bind(
1208 (cl_loop_binder_f)Fset,
1209 fc->hash_valvar, e->value);
1211 fc->ptr1 = cl_loop_next_hentry(e, XHASH_TABLE(fc->curbound));
1214 case FOR_INVALID_CLAUSE:
1222 cl_loop_perform_for(cl_loop_for_clause_t *fc)
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);
1232 cl_loop_perform_for_i(fc);
1234 while (!NILP(tra)) {
1235 cl_loop_for_clause_t *fct = get_dynacat(tra);
1236 cl_loop_perform_for_i(fct);
1240 /* now specbind them */
1241 state = cl_loop_perform_for_b(fc);
1243 while (!NILP(tra)) {
1244 cl_loop_for_clause_t *fct = get_dynacat(tra);
1245 state &= cl_loop_perform_for_b(fct);
1253 cl_loop_perform_do(cl_loop_do_clause_t *dc)
1260 cl_loop_perform_repeat(cl_loop_repeat_clause_t *rc)
1262 if (--rc->counter > 0) {
1269 cl_loop_perform_collect(cl_loop_accu_clause_t *ac)
1272 ac->cur = XCDR(ac->cur) = Fcons(Feval(ac->form), Qnil);
1274 Fset(ac->into, ac->cur = Fcons(Feval(ac->form), Qnil));
1280 cl_loop_perform_append(cl_loop_accu_clause_t *ac)
1282 Lisp_Object form = Feval(ac->form);
1285 XCDR(ac->cur) = form;
1287 Fset(ac->into, ac->cur = form);
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)))
1294 return wrong_type_argument(Qlistp, form);
1298 cl_loop_perform_nconc(cl_loop_accu_clause_t *ac)
1300 Lisp_Object form = Feval(ac->form);
1301 if (!NILP(ac->cur) && CONSP(ac->cur)) {
1302 XCDR(ac->cur) = form;
1304 Fset(ac->into, ac->cur = form);
1306 while (CONSP(ac->cur) &&
1307 !NILP(XCDR(ac->cur)) &&
1308 CONSP(XCDR(ac->cur)))
1309 ac->cur = XCDR(ac->cur);
1314 cl_loop_perform_count(cl_loop_accu_clause_t *ac)
1316 if (!NILP(Feval(ac->form))) {
1317 Fset(ac->into, ac->cur = make_int(XINT(ac->cur)+1));
1323 cl_loop_perform_sum(cl_loop_accu_clause_t *ac)
1325 Lisp_Object form = Feval(ac->form);
1328 ac->cur = ent_binop(ASE_BINARY_OP_SUM, ac->cur, form));
1333 cl_loop_perform_maximise(cl_loop_accu_clause_t *ac)
1335 Lisp_Object form = Feval(ac->form);
1337 if (ent_binrel(ASE_BINARY_REL_GREATERP, form, ac->cur))
1338 Fset(ac->into, ac->cur = form);
1343 cl_loop_perform_minimise(cl_loop_accu_clause_t *ac)
1345 Lisp_Object form = Feval(ac->form);
1347 if (ent_binrel(ASE_BINARY_REL_LESSP, form, ac->cur))
1348 Fset(ac->into, ac->cur = form);
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)
1359 return symbol_value(XSYMBOL(ac->into));
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)
1369 return Feval(rc->form);
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)
1379 return *result = Feval(rc->form);
1384 cl_loop_prologue(Lisp_Object clause)
1388 emp = get_dynacat(clause);
1389 if (EQ(get_dynacat_type(clause), Qcl_loop_repeat_clause)) {
1390 cl_loop_perform_repeat_pro(emp);
1393 if (EQ(get_dynacat_type(clause), Qcl_loop_for_clause)) {
1394 cl_loop_perform_for_pro(emp);
1397 if (EQ(get_dynacat_type(clause), Qcl_loop_with_clause)) {
1398 cl_loop_perform_with_pro(emp);
1401 if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause)) {
1402 cl_loop_perform_colappnco_pro(emp);
1405 if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1406 cl_loop_perform_colappnco_pro(emp);
1409 if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1410 cl_loop_perform_colappnco_pro(emp);
1413 if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1414 cl_loop_perform_countsum_pro(emp);
1417 if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1418 cl_loop_perform_countsum_pro(emp);
1421 if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1422 cl_loop_perform_maximise_pro(emp);
1425 if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1426 cl_loop_perform_minimise_pro(emp);
1429 if (EQ(get_dynacat_type(clause), Qcl_loop_initially_clause)) {
1430 cl_loop_perform_initially_pro(emp);
1438 cl_loop_epilogue(Lisp_Object *result, Lisp_Object clause)
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);
1446 if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1447 return cl_loop_perform_accu_epi(result, emp);
1449 if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1450 return cl_loop_perform_accu_epi(result, emp);
1452 if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1453 return cl_loop_perform_accu_epi(result, emp);
1455 if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1456 return cl_loop_perform_accu_epi(result, emp);
1458 if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1459 return cl_loop_perform_accu_epi(result, emp);
1461 if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1462 return cl_loop_perform_accu_epi(result, emp);
1464 if (EQ(get_dynacat_type(clause), Qcl_loop_return_clause)) {
1465 return cl_loop_perform_return_epi(result, emp);
1467 if (EQ(get_dynacat_type(clause), Qcl_loop_finally_clause)) {
1468 return cl_loop_perform_finally_epi(result, emp);
1470 return Qnull_pointer;
1474 cl_loop_iteration(Lisp_Object clause)
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);
1504 cl_loop_dllist_map(int(*fun)(Lisp_Object), dllist_t dll)
1507 dllist_item_t item = dllist_first(dll);
1515 state &= fun((Lisp_Object)item->item);
1522 cl_loop_dllist_map_return(
1523 Lisp_Object *result,
1524 Lisp_Object(*fun)(Lisp_Object*, Lisp_Object), dllist_t dll)
1526 dllist_item_t item = dllist_first(dll);
1527 Lisp_Object ret = Qnil;
1534 ret = fun(result, (Lisp_Object)item->item);
1537 if (!EQ(ret, Qnull_pointer))
1544 cl_loop_perform(cl_loop_sentence_t *lsen)
1546 dllist_t pro = XDLLIST(lsen->prologue);
1547 dllist_t epi = XDLLIST(lsen->epilogue);
1548 dllist_t iter = XDLLIST(lsen->iteration);
1549 int speccount = specpdl_depth();
1554 /* traverse the prologue */
1555 cl_loop_dllist_map(cl_loop_prologue, pro);
1556 /* traverse the iteration */
1557 while (lsen->state) {
1559 lsen->state = cl_loop_dllist_map(cl_loop_iteration, iter);
1561 /* traverse the epilogue */
1562 lsen->result = Qnull_pointer;
1563 res = cl_loop_dllist_map_return(&lsen->result, cl_loop_epilogue, epi);
1565 unbind_to(speccount, Qnil);
1567 return lsen->result;
1574 DEFUN("cl:loop-sentence", Fcl_loop_sentence, 0, UNEVALLED, 0, /*
1575 The Common Lisp loop macro.
1579 Lisp_Object loop_sentence = cl_loop_make_sentence();
1580 Lisp_Object context = Qnil, token = Qnil;
1581 cl_loop_sentence_t *lsen = get_dynacat(loop_sentence);
1583 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1585 GCPRO4(args, loop_sentence, context, token);
1587 /* now parse the stuff */
1588 parse_result = cl_loop_yyparse(&args, lsen, &context, &token);
1592 return loop_sentence;
1595 DEFUN("cl:loop*", Fcl_loopX, 1, 1, 0, /*
1596 Execute LOOP-SENTENCE.
1600 Lisp_Object result = Qnil;
1601 struct gcpro gcpro1, gcpro2;
1603 CHECK_CL_LOOP_SENTENCE(loop_sentence);
1605 GCPRO2(result, loop_sentence);
1607 result = cl_loop_perform(XCL_LOOP_SENTENCE(loop_sentence));
1613 DEFUN("cl:loop", Fcl_loop, 0, UNEVALLED, 0, /*
1614 The Common Lisp loop macro.
1618 Lisp_Object loop_sentence = Qnil;
1619 Lisp_Object result = Qnil;
1620 struct gcpro gcpro1, gcpro2;
1621 cl_loop_sentence_t *lsen;
1631 GCPRO2(result, loop_sentence);
1633 loop_sentence = Fcl_loop_sentence(args);
1634 lsen = get_dynacat(loop_sentence);
1635 result = cl_loop_perform(lsen);
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...)
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();
1657 CHECK_CONS(varform);
1658 CHECK_CONS(endform);
1660 GCPRO2(endtest, resultform);
1662 endtest = XCAR(endform);
1663 resultform = XCDR(endform);
1666 varform, endtest, resultform, body,
1667 emodcl_initialise_vars, emodcl_step_vars);
1669 unbind_to(speccount, Qnil);
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...)
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();
1690 CHECK_CONS(varform);
1691 CHECK_CONS(endform);
1693 GCPRO4(result, endtest, resultform, body);
1695 endtest = XCAR(endform);
1696 resultform = XCDR(endform);
1699 varform, endtest, resultform, body,
1700 emodcl_initialise_vars_star, emodcl_step_vars_star);
1702 unbind_to(speccount, Qnil);
1709 DEFUN("cl:dotimes", Fcl_dotimes, 1, UNEVALLED, 0, /*
1710 The Common Lisp `dotimes' loop.
1711 Format is: (dotimes (VAR COUNT [RESULT]) BODY...)
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();
1724 CHECK_CONS(varform);
1725 CHECK_CONS(XCDR(varform));
1726 CHECK_SYMBOL(varsym = XCAR(varform));
1728 GCPRO3(result, varform, body);
1729 CHECK_NATNUM(varcnt = Feval(XCAR(XCDR(varform))));
1731 specbind(varsym, Qzero);
1732 for (j = 0; j < XUINT(varcnt); j++) {
1733 Fset(varsym, make_int(j));
1734 LIST_LOOP_2(form, body) {
1739 if (!NILP(resultform = XCDR(XCDR(varform)))) {
1740 LIST_LOOP_2(form, resultform) {
1741 result = Feval(form);
1745 unbind_to(speccount, Qnil);
1751 DEFUN("cl:dolist", Fcl_dolist, 1, UNEVALLED, 0, /*
1752 The Common Lisp `dolist' loop.
1753 Format is: (dolist (VAR LIST [RESULT]) BODY...)
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();
1765 CHECK_CONS(varform);
1766 CHECK_CONS(XCDR(varform));
1767 CHECK_SYMBOL(varsym = XCAR(varform));
1769 GCPRO3(result, varform, body);
1770 list = Feval(XCAR(XCDR(varform)));
1778 specbind(varsym, Qnil);
1779 while (!NILP(list)) {
1780 Fset(varsym, XCAR(list));
1781 LIST_LOOP_2(form, body) {
1788 if (!NILP(resultform = XCDR(XCDR(varform)))) {
1789 LIST_LOOP_2(form, resultform) {
1790 result = Feval(form);
1794 unbind_to(speccount, Qnil);
1799 extern Lisp_Object check_obarray(Lisp_Object obarray);
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...)
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();
1816 CHECK_CONS(varform);
1817 CHECK_SYMBOL(varsym = XCAR(varform));
1819 GCPRO3(result, varform, body);
1821 if (NILP(XCDR(varform))) {
1824 CHECK_CONS(XCDR(varform));
1825 obarr = Feval(XCAR(XCDR(varform)));
1827 obarr = check_obarray(obarr);
1829 specbind(varsym, Qnil);
1830 for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
1831 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
1836 LIST_LOOP_2(form, body) {
1839 next = symbol_next(XSYMBOL(tail));
1842 XSETSYMBOL(tail, next);
1846 if (!NILP(XCDR(varform)) &&
1847 !NILP(resultform = XCDR(XCDR(varform)))) {
1848 LIST_LOOP_2(form, resultform) {
1849 result = Feval(form);
1853 unbind_to(speccount, Qnil);
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...)
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();
1874 CHECK_CONS(varform);
1875 CHECK_SYMBOL(varsym = XCAR(varform));
1877 GCPRO3(result, varform, body);
1881 specbind(varsym, Qnil);
1882 for (j = XVECTOR_LENGTH(obarr)-1; j >= 0; j--) {
1883 Lisp_Object tail = XVECTOR_DATA(obarr)[j];
1888 LIST_LOOP_2(form, body) {
1891 next = symbol_next(XSYMBOL(tail));
1894 XSETSYMBOL(tail, next);
1898 if (!NILP(resultform = XCDR(varform))) {
1899 LIST_LOOP_2(form, resultform) {
1900 result = Feval(form);
1904 unbind_to(speccount, Qnil);
1910 /* simplified initialisation */
1914 DEFSUBR(Fcl_loop_sentence);
1919 DEFSUBR(Fcl_dotimes);
1920 DEFSUBR(Fcl_dolist);
1921 DEFSUBR(Fcl_do_symbols);
1922 DEFSUBR(Fcl_do_all_symbols);
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);
1958 DEFSYMBOL(Qdownfrom);
1973 DEFSYMBOL(Qhash_key);
1974 DEFSYMBOL(Qhash_keys);
1975 DEFSYMBOL(Qhash_value);
1976 DEFSYMBOL(Qhash_values);
1982 defsymbol(&Qequals, "=");
1985 DEFSYMBOL(Qappending);
1986 DEFSYMBOL(Qcollect);
1987 DEFSYMBOL(Qcollecting);
1989 DEFSYMBOL(Qnconcing);
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);
2009 DEFSYMBOL(Qinitially);
2010 DEFSYMBOL(Qfinally);
2012 DEFSYMBOL(Qanon_acn);
2014 Fprovide(intern("cl-loop"));
2020 Frevoke(intern("cl-loop"));
2023 /* cl-loop.c ends here */