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. */
44 #if !defined EMOD_CL_MONOMOD
46 REQUIRE(cl_loop, "cl");
48 #define INIT cl_loop_LTX_init
49 #define REINIT cl_loop_LTX_reinit
50 #define DEINIT cl_loop_LTX_deinit
53 emodcl_initialise_vars(Lisp_Object varform)
54 __attribute__((always_inline));
56 emodcl_step_vars(Lisp_Object varform, int varcount)
57 __attribute__((always_inline));
59 Lisp_Object Qcl_loop_sentence, Qcl_loop_sentence_p;
60 Lisp_Object Qcl_loop_for_clause, Qcl_loop_for_clause_p;
61 Lisp_Object Qcl_loop_do_clause, Qcl_loop_do_clause_p;
62 Lisp_Object Qcl_loop_with_clause, Qcl_loop_with_clause_p;
63 Lisp_Object Qcl_loop_repeat_clause, Qcl_loop_repeat_clause_p;
64 Lisp_Object Qcl_loop_append_clause, Qcl_loop_append_clause_p;
65 Lisp_Object Qcl_loop_collect_clause, Qcl_loop_collect_clause_p;
66 Lisp_Object Qcl_loop_nconc_clause, Qcl_loop_nconc_clause_p;
67 Lisp_Object Qcl_loop_return_clause, Qcl_loop_return_clause_p;
68 Lisp_Object Qcl_loop_initially_clause, Qcl_loop_initially_clause_p;
69 Lisp_Object Qcl_loop_finally_clause, Qcl_loop_finally_clause_p;
70 Lisp_Object Qcl_loop_count_clause, Qcl_loop_count_clause_p;
71 Lisp_Object Qcl_loop_sum_clause, Qcl_loop_sum_clause_p;
72 Lisp_Object Qcl_loop_maximise_clause, Qcl_loop_maximise_clause_p;
73 Lisp_Object Qcl_loop_minimise_clause, Qcl_loop_minimise_clause_p;
75 Lisp_Object Qfor, Qas;
76 Lisp_Object Qfrom, Qdownfrom, Qupfrom, Qto, Qdownto, Qupto, Qabove, Qbelow, Qby;
77 Lisp_Object Qin, Qon, Qthen, Qacross, Qeach, Qthe, Qbeing, Qof;
78 Lisp_Object Qhash_key, Qhash_keys, Qhash_value, Qhash_values, Qusing;
79 Lisp_Object Qdo, Qdoing;
81 Lisp_Object Qwith, Qequals, Qand;
83 Lisp_Object Qappend, Qappending, Qcollect, Qcollecting, Qnconc, Qnconcing;
85 Lisp_Object Qcount, Qcounting, Qsum, Qsumming;
86 Lisp_Object Qmaximise, Qmaximising, Qmaximize, Qmaximizing;
87 Lisp_Object Qminimise, Qminimising, Qminimize, Qminimizing;
88 Lisp_Object Qinitially, Qfinally;
90 static Lisp_Object Qanon_acn;
94 emodcl_initialise_vars(Lisp_Object varform)
100 /* Make space to hold the values to give the bound variables. */
101 GET_EXTERNAL_LIST_LENGTH(varform, varcount);
104 Lisp_Object temps[varcount];
105 struct gcpro ngcpro1;
107 /* wipe temps first */
108 memset(temps, 0, sizeof(Lisp_Object)*varcount);
110 /* Compute the values and store them in `temps' */
111 NGCPROn(temps, varcount);
113 LIST_LOOP_2(var, varform) {
114 Lisp_Object *value = &temps[idx++];
125 *value = Feval(XCAR(tem));
132 LIST_LOOP_2(var, varform) {
133 specbind(SYMBOLP(var) ? var : XCAR(var), temps[idx++]);
143 emodcl_step_vars(Lisp_Object varform, int varcount)
145 /* basically a let */
146 Lisp_Object temps[varcount];
147 struct gcpro ngcpro1;
150 /* wipe temps first */
151 memset(temps, 0, sizeof(Lisp_Object)*varcount);
153 /* Compute the values and store them in `temps' */
154 NGCPROn(temps, varcount);
156 LIST_LOOP_2(var, varform) {
157 Lisp_Object *value = &temps[idx++];
159 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
161 /* only if there is a step form of course */
162 *value = Feval(XCAR(XCDR(tmp)));
167 LIST_LOOP_2(var, varform) {
168 Fset(XCAR(var), temps[idx++]);
176 emodcl_initialise_vars_star(Lisp_Object varform)
178 /* basically a let* */
179 EXTERNAL_LIST_LOOP_3(var, varform, tail) {
180 Lisp_Object symbol, value, tem;
182 symbol = var, value = Qnil;
191 value = Feval(XCAR(tem));
194 specbind(symbol, value);
200 emodcl_step_vars_star(Lisp_Object varform, int unused)
202 EXTERNAL_LIST_LOOP_3(var, varform, tail) {
203 Lisp_Object symbol, value, tmp;
204 if (CONSP(var) && CONSP((tmp = XCDR(var))) &&
206 /* only if there is a step form of course */
208 value = Feval(XCAR(XCDR(tmp)));
215 static inline Lisp_Object
216 emodcl_do_obtain_result(Lisp_Object resultform)
218 /* assumes that resultform is gc-protected already */
219 Lisp_Object result = Qnil;
221 LIST_LOOP_2(form, resultform) {
222 result = Feval(form);
230 Lisp_Object varform, Lisp_Object endtest, Lisp_Object resultform,
232 int(*initialiser)(Lisp_Object), void(*stepper)(Lisp_Object, int))
234 Lisp_Object result = Qnil;
237 /* initial assignment */
238 numbervars = initialiser(varform);
241 while (NILP(Feval(endtest))) {
243 LIST_LOOP_2(form, body) {
247 internal_catch(tag, Fprogn, body, 0);
249 /* evaluate step forms */
250 stepper(varform, numbervars);
253 /* obtain a result */
254 result = emodcl_do_obtain_result(resultform);
261 cl_loop_sentence_mark(Lisp_Object obj)
263 cl_loop_sentence_t *lsen = get_dynacat(obj);
265 EMOD_CL_DEBUG_LOOP("sentence:0x%x@0x%x shall be marked...\n",
266 (unsigned int)(lsen), (unsigned int)obj);
268 mark_object(lsen->prologue);
269 mark_object(lsen->epilogue);
270 mark_object(lsen->iteration);
272 mark_object(lsen->result);
277 cl_loop_for_clause_mark(Lisp_Object obj)
279 cl_loop_for_clause_t *fc = get_dynacat(obj);
281 EMOD_CL_DEBUG_LOOP("FOR:0x%x@0x%x shall be marked...\n",
282 (unsigned int)(fc), (unsigned int)obj);
284 mark_object(fc->form1);
285 mark_object(fc->from);
289 mark_object(fc->inonacross);
291 mark_object(fc->equals);
292 mark_object(fc->then);
294 mark_object(fc->hash_keyvar);
295 mark_object(fc->hash_valvar);
297 mark_object(fc->curval);
298 mark_object(fc->curbound);
299 mark_object(fc->curstep);
304 cl_loop_do_clause_mark(Lisp_Object obj)
306 cl_loop_do_clause_t *doc = get_dynacat(obj);
308 EMOD_CL_DEBUG_LOOP("DO:0x%x@0x%x shall be marked...\n",
309 (unsigned int)(doc), (unsigned int)obj);
311 mark_object(doc->form);
316 cl_loop_with_clause_mark(Lisp_Object obj)
318 cl_loop_with_clause_t *wc = get_dynacat(obj);
320 EMOD_CL_DEBUG_LOOP("WITH:0x%x@0x%x shall be marked...\n",
321 (unsigned int)(wc), (unsigned int)obj);
323 mark_object(wc->varform);
324 mark_object(wc->valform);
325 mark_object(wc->next);
330 cl_loop_repeat_clause_mark(Lisp_Object obj)
332 cl_loop_repeat_clause_t *rc = get_dynacat(obj);
334 EMOD_CL_DEBUG_LOOP("REPEAT:0x%x@0x%x shall be marked...\n",
335 (unsigned int)(rc), (unsigned int)obj);
337 mark_object(rc->form);
342 cl_loop_inifinret_clause_mark(Lisp_Object obj)
344 cl_loop_inifinret_clause_t *rc = get_dynacat(obj);
346 EMOD_CL_DEBUG_LOOP("RETURN|INITIALLY|FINALLY:"
347 "0x%x@0x%x shall be marked...\n",
348 (unsigned int)(rc), (unsigned int)obj);
350 mark_object(rc->form);
355 cl_loop_accu_clause_mark(Lisp_Object obj)
357 cl_loop_accu_clause_t *ac = get_dynacat(obj);
359 EMOD_CL_DEBUG_LOOP("ACCU(=COLLECT|APPEND|NCONC|etc.):"
360 "0x%x@0x%x shall be marked...\n",
361 (unsigned int)(ac), (unsigned int)obj);
363 mark_object(ac->form);
364 mark_object(ac->into);
365 mark_object(ac->cur);
370 cl_loop_generic_finaliser(Lisp_Object obj, int SXE_UNUSED(for_disksave))
372 void *free_me = get_dynacat(obj);
374 EMOD_CL_DEBUG_LOOP("generic:%p@%p shall be freed\n",
375 free_me, (void*)obj);
378 set_dynacat(obj, NULL);
383 /* auxiliary stuff */
384 typedef void(*cl_loop_binder_f)(Lisp_Object, Lisp_Object);
387 cl_loop_destructuring_bind(
388 cl_loop_binder_f bindfun, Lisp_Object form, Lisp_Object value)
390 Lisp_Object tmpf, tmpv;
391 while (!NILP(form)) {
393 bindfun(form, value);
400 /* recursive approach? :| */
401 cl_loop_destructuring_bind(bindfun, tmpf, tmpv);
410 static inline Lisp_Object
411 cl_loop_make_sentence(void)
413 cl_loop_sentence_t *lsen = xnew_and_zero(cl_loop_sentence_t);
414 Lisp_Object result = make_dynacat(lsen);
416 set_dynacat_type(result, Qcl_loop_sentence);
418 XSETDLLIST(lsen->prologue, make_dllist());
419 XSETDLLIST(lsen->epilogue, make_dllist());
420 XSETDLLIST(lsen->iteration, make_dllist());
424 set_dynacat_marker(result, cl_loop_sentence_mark);
425 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
427 EMOD_CL_DEBUG_LOOP("sentence:0x%x shall be wrapped to 0x%x...\n",
428 (unsigned int)lsen, (unsigned int)result);
434 cl_loop_make_for_clause(Lisp_Object form1)
436 cl_loop_for_clause_t *fc = xnew_and_zero(cl_loop_for_clause_t);
437 Lisp_Object result = make_dynacat(fc);
439 set_dynacat_type(result, Qcl_loop_for_clause);
442 fc->for_subclause = FOR_INVALID_CLAUSE;
444 /* arith subclause */
448 /* by default we increment and compare with equalp */
449 fc->byop = ASE_BINARY_OP_SUM;
450 fc->torel = ASE_BINARY_REL_LESSP;
451 fc->torel_strictp = 0;
453 /* in/on subclauses */
454 fc->inonacross = Qnil;
461 fc->hash_keyvar = Qnil;
462 fc->hash_valvar = Qnil;
464 /* for parallel bind */
470 fc->curbound = Qzero;
474 set_dynacat_marker(result, cl_loop_for_clause_mark);
475 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
477 EMOD_CL_DEBUG_LOOP("FOR:0x%x shall be wrapped to 0x%x...\n",
478 (unsigned int)fc, (unsigned int)result);
484 cl_loop_make_do_clause(Lisp_Object form1)
486 cl_loop_do_clause_t *doc = xnew_and_zero(cl_loop_do_clause_t);
487 Lisp_Object result = make_dynacat(doc);
489 set_dynacat_type(result, Qcl_loop_do_clause);
493 set_dynacat_marker(result, cl_loop_do_clause_mark);
494 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
496 EMOD_CL_DEBUG_LOOP("DO:0x%x shall be wrapped to 0x%x...\n",
497 (unsigned int)doc, (unsigned int)result);
503 cl_loop_make_repeat_clause(Lisp_Object form)
505 cl_loop_repeat_clause_t *rc = xnew_and_zero(cl_loop_repeat_clause_t);
506 Lisp_Object result = make_dynacat(rc);
508 set_dynacat_type(result, Qcl_loop_repeat_clause);
513 set_dynacat_marker(result, cl_loop_repeat_clause_mark);
514 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
516 EMOD_CL_DEBUG_LOOP("REPEAT:0x%x shall be wrapped to 0x%x...\n",
517 (unsigned int)rc, (unsigned int)result);
523 cl_loop_make_return_clause(Lisp_Object form)
525 cl_loop_inifinret_clause_t *rc =
526 xnew_and_zero(cl_loop_inifinret_clause_t);
527 Lisp_Object result = make_dynacat(rc);
529 set_dynacat_type(result, Qcl_loop_return_clause);
533 set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
534 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
536 EMOD_CL_DEBUG_LOOP("RETURN:0x%x shall be wrapped to 0x%x...\n",
537 (unsigned int)rc, (unsigned int)result);
543 cl_loop_make_initially_clause(Lisp_Object form)
545 cl_loop_inifinret_clause_t *rc =
546 xnew_and_zero(cl_loop_inifinret_clause_t);
547 Lisp_Object result = make_dynacat(rc);
549 set_dynacat_type(result, Qcl_loop_initially_clause);
553 set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
554 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
556 EMOD_CL_DEBUG_LOOP("INITIALLY:0x%x shall be wrapped to 0x%x...\n",
557 (unsigned int)rc, (unsigned int)result);
563 cl_loop_make_finally_clause(Lisp_Object form)
565 cl_loop_inifinret_clause_t *rc =
566 xnew_and_zero(cl_loop_inifinret_clause_t);
567 Lisp_Object result = make_dynacat(rc);
569 set_dynacat_type(result, Qcl_loop_finally_clause);
573 set_dynacat_marker(result, cl_loop_inifinret_clause_mark);
574 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
576 EMOD_CL_DEBUG_LOOP("FINALLY:0x%x shall be wrapped to 0x%x...\n",
577 (unsigned int)rc, (unsigned int)result);
582 /* maybe a generic cl_loop_make_accu_clause? */
584 cl_loop_make_append_clause(Lisp_Object form)
586 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
587 Lisp_Object result = make_dynacat(ac);
589 set_dynacat_type(result, Qcl_loop_append_clause);
595 set_dynacat_marker(result, cl_loop_accu_clause_mark);
596 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
598 EMOD_CL_DEBUG_LOOP("APPEND:0x%x shall be wrapped to 0x%x...\n",
599 (unsigned int)ac, (unsigned int)result);
605 cl_loop_make_collect_clause(Lisp_Object form)
607 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
608 Lisp_Object result = make_dynacat(ac);
610 set_dynacat_type(result, Qcl_loop_collect_clause);
616 set_dynacat_marker(result, cl_loop_accu_clause_mark);
617 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
619 EMOD_CL_DEBUG_LOOP("COLLECT:0x%x shall be wrapped to 0x%x...\n",
620 (unsigned int)ac, (unsigned int)result);
626 cl_loop_make_nconc_clause(Lisp_Object form)
628 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
629 Lisp_Object result = make_dynacat(ac);
631 set_dynacat_type(result, Qcl_loop_nconc_clause);
637 set_dynacat_marker(result, cl_loop_accu_clause_mark);
638 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
640 EMOD_CL_DEBUG_LOOP("NCONC:0x%x shall be wrapped to 0x%x...\n",
641 (unsigned int)ac, (unsigned int)result);
647 cl_loop_make_count_clause(Lisp_Object form)
649 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
650 Lisp_Object result = make_dynacat(ac);
652 set_dynacat_type(result, Qcl_loop_count_clause);
658 set_dynacat_marker(result, cl_loop_accu_clause_mark);
659 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
661 EMOD_CL_DEBUG_LOOP("COUNT:0x%x shall be wrapped to 0x%x...\n",
662 (unsigned int)ac, (unsigned int)result);
668 cl_loop_make_sum_clause(Lisp_Object form)
670 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
671 Lisp_Object result = make_dynacat(ac);
673 set_dynacat_type(result, Qcl_loop_sum_clause);
679 set_dynacat_marker(result, cl_loop_accu_clause_mark);
680 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
682 EMOD_CL_DEBUG_LOOP("SUM:0x%x shall be wrapped to 0x%x...\n",
683 (unsigned int)ac, (unsigned int)result);
689 cl_loop_make_maximise_clause(Lisp_Object form)
691 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
692 Lisp_Object result = make_dynacat(ac);
694 set_dynacat_type(result, Qcl_loop_maximise_clause);
700 set_dynacat_marker(result, cl_loop_accu_clause_mark);
701 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
703 EMOD_CL_DEBUG_LOOP("MAXIMISE:0x%x shall be wrapped to 0x%x...\n",
704 (unsigned int)ac, (unsigned int)result);
710 cl_loop_make_minimise_clause(Lisp_Object form)
712 cl_loop_accu_clause_t *ac = xnew_and_zero(cl_loop_accu_clause_t);
713 Lisp_Object result = make_dynacat(ac);
715 set_dynacat_type(result, Qcl_loop_minimise_clause);
721 set_dynacat_marker(result, cl_loop_accu_clause_mark);
722 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
724 EMOD_CL_DEBUG_LOOP("MINIMISE:0x%x shall be wrapped to 0x%x...\n",
725 (unsigned int)ac, (unsigned int)result);
731 cl_loop_make_with_clause(Lisp_Object form)
733 cl_loop_with_clause_t *wc = xnew_and_zero(cl_loop_with_clause_t);
734 Lisp_Object result = make_dynacat(wc);
736 set_dynacat_type(result, Qcl_loop_with_clause);
743 set_dynacat_marker(result, cl_loop_with_clause_mark);
744 set_dynacat_finaliser(result, cl_loop_generic_finaliser);
746 EMOD_CL_DEBUG_LOOP("WITH:0x%x shall be wrapped to 0x%x...\n",
747 (unsigned int)wc, (unsigned int)result);
754 cl_loop_yylex(YYSTYPE *yys, Lisp_Object *scanner,
755 cl_loop_sentence_t *lsen, Lisp_Object *ctx, Lisp_Object *token)
762 tok = *token = XCAR(*scanner);
763 *scanner = XCDR(*scanner);
765 if (EQ(tok, Qrepeat)) {
766 return *yys = REPEAT;
768 if (EQ(tok, Qfor) || EQ(tok, Qas)) {
771 if (EQ(tok, Qdo) || EQ(tok, Qdoing)) {
774 if (EQ(tok, Qwith)) {
781 if (EQ(tok, Qfrom) ||
782 EQ(tok, Qdownfrom) ||
791 if (EQ(tok, Qbelow)) {
794 if (EQ(tok, Qabove)) {
806 if (EQ(tok, Qequals)) {
807 return *yys = EQUALS;
809 if (EQ(tok, Qthen)) {
812 if (EQ(tok, Qacross)) {
813 return *yys = ACROSS;
815 if (EQ(tok, Qbeing)) {
818 if (EQ(tok, Qthe) || EQ(tok, Qeach)) {
821 if (EQ(tok, Qof) || EQ(tok, Qin)) {
824 if (EQ(tok, Qhash_key) || EQ(tok, Qhash_keys)) {
825 return *yys = HASH_KEY;
827 if (EQ(tok, Qhash_value) || EQ(tok, Qhash_values)) {
828 return *yys = HASH_VALUE;
830 if (EQ(tok, Qusing)) {
833 if (EQ(tok, Qcollect) || EQ(tok, Qcollecting)) {
834 return *yys = COLLECT;
836 if (EQ(tok, Qappend) || EQ(tok, Qappending)) {
837 return *yys = APPEND;
839 if (EQ(tok, Qnconc) || EQ(tok, Qnconcing)) {
842 if (EQ(tok, Qcount) || EQ(tok, Qcount)) {
845 if (EQ(tok, Qsum) || EQ(tok, Qsumming)) {
848 if (EQ(tok, Qminimise) || EQ(tok, Qminimising) ||
849 EQ(tok, Qminimize) || EQ(tok, Qminimizing)) {
850 return *yys = MINIMISE;
852 if (EQ(tok, Qmaximise) || EQ(tok, Qmaximising) ||
853 EQ(tok, Qmaximize) || EQ(tok, Qmaximizing)) {
854 return *yys = MAXIMISE;
856 if (EQ(tok, Qinto)) {
859 if (EQ(tok, Qinitially)) {
860 return *yys = INITIALLY;
862 if (EQ(tok, Qfinally)) {
863 return *yys = FINALLY;
865 if (EQ(tok, Qreturn)) {
866 return *yys = RETURN;
873 cl_loop_yyerror(Lisp_Object *scanner, cl_loop_sentence_t *lsen,
874 Lisp_Object *ctx, Lisp_Object *token, char *msg)
876 Fsignal(Qinvalid_read_syntax, *scanner);
882 cl_loop_perform_with_pro(cl_loop_with_clause_t *wc)
884 Lisp_Object val = Feval(wc->valform);
885 if (wc->depth == 1) {
886 /* optimise for the trivial case */
887 cl_loop_destructuring_bind(specbind, wc->varform, val);
889 Lisp_Object *tmp = alloca_array(Lisp_Object, wc->depth);
895 for (i = 1; !NILP(tra); i++) {
896 cl_loop_with_clause_t *wct = get_dynacat(tra);
897 tmp[i] = Feval(wct->valform);
901 /* now specbind them */
902 cl_loop_destructuring_bind(specbind, wc->varform, tmp[0]);
904 for (i = 1; !NILP(tra); i++) {
905 cl_loop_with_clause_t *wct = get_dynacat(tra);
906 cl_loop_destructuring_bind(
907 specbind, wct->varform, tmp[i]);
914 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
915 __attribute__((always_inline));
917 cl_loop_perform_colappnco_pro(cl_loop_accu_clause_t *ac)
919 if (ac->into == Qnull_pointer) {
920 /* generate a random symbol */
921 ac->into = Qanon_acn;
923 specbind(ac->into, ac->cur = Qnil);
927 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
928 __attribute__((always_inline));
930 cl_loop_perform_countsum_pro(cl_loop_accu_clause_t *ac)
932 if (ac->into == Qnull_pointer) {
933 /* generate a random symbol */
934 ac->into = Qanon_acn;
936 specbind(ac->into, ac->cur = Qzero);
940 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
941 __attribute__((always_inline));
943 cl_loop_perform_maximise_pro(cl_loop_accu_clause_t *ac)
945 if (ac->into == Qnull_pointer) {
946 /* generate a random symbol */
947 ac->into = Qanon_acn;
949 specbind(ac->into, ac->cur = Vninfinity);
953 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
954 __attribute__((always_inline));
956 cl_loop_perform_minimise_pro(cl_loop_accu_clause_t *ac)
958 if (ac->into == Qnull_pointer) {
959 /* generate a random symbol */
960 ac->into = Qanon_acn;
962 specbind(ac->into, ac->cur = Vpinfinity);
966 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
967 __attribute__((always_inline));
969 cl_loop_perform_repeat_pro(cl_loop_repeat_clause_t *rc)
971 Lisp_Object lctr = Feval(rc->form);
973 rc->counter = XINT(lctr);
978 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
979 __attribute__((always_inline));
981 cl_loop_perform_initially_pro(cl_loop_inifinret_clause_t *rc)
988 cl_loop_next_hentry(hentry_t e, const hash_table_t ht)
990 const hentry_t term = ht->hentries + ht->size;
996 while (e < term && HENTRY_CLEAR_P(++e));
1005 cl_loop_perform_for_pro_i(cl_loop_for_clause_t *fc)
1007 switch (fc->for_subclause) {
1008 case FOR_ARITHMETIC_CLAUSE:
1009 fc->curval = Feval(fc->from);
1010 fc->curbound = Feval(fc->to);
1011 fc->curstep = Feval(fc->by);
1013 case FOR_IN_SUBLIST_CLAUSE:
1014 fc->curbound = Feval(fc->inonacross);
1015 /* error handling here, make sure curbound is a cons */
1016 CHECK_CONS(fc->curbound);
1017 fc->curval = XCAR(fc->curbound);
1019 case FOR_ON_SUBLIST_CLAUSE:
1020 fc->curbound = Feval(fc->inonacross);
1021 CHECK_CONS(fc->curbound);
1022 fc->curval = fc->curbound;
1024 case FOR_ACROSS_ARRAY_CLAUSE:
1025 fc->curbound = Feval(fc->inonacross);
1026 fc->bound = XINT(Flength(fc->curbound));
1027 /* CHECK_ARRAY(fc->curbound); */
1029 fc->curval = Faref(fc->curbound, Qzero);
1031 case FOR_EQUALS_THEN_CLAUSE:
1032 fc->curval = Feval(fc->equals);
1035 case FOR_OF_HASHTABLE_CLAUSE: {
1037 fc->curbound = Feval(fc->inonacross);
1038 e = cl_loop_next_hentry(
1039 NULL, XHASH_TABLE(fc->curbound));
1040 if ((fc->ptr1 = e) == NULL) {
1046 case FOR_INVALID_CLAUSE:
1048 /* there are `for' subclauses without stuff in the prologue */
1055 cl_loop_perform_for_pro_b(cl_loop_for_clause_t *fc)
1057 switch (fc->for_subclause) {
1058 case FOR_ARITHMETIC_CLAUSE:
1059 case FOR_IN_SUBLIST_CLAUSE:
1060 case FOR_ON_SUBLIST_CLAUSE:
1061 case FOR_ACROSS_ARRAY_CLAUSE:
1062 case FOR_EQUALS_THEN_CLAUSE:
1063 cl_loop_destructuring_bind(specbind, fc->form1, fc->curval);
1066 case FOR_OF_HASHTABLE_CLAUSE: {
1067 hentry_t e = fc->ptr1;
1071 if (!NILP(fc->hash_keyvar)) {
1072 cl_loop_destructuring_bind(
1073 specbind, fc->hash_keyvar, e->key);
1075 if (!NILP(fc->hash_valvar)) {
1076 cl_loop_destructuring_bind(
1077 specbind, fc->hash_valvar, e->value);
1081 case FOR_INVALID_CLAUSE:
1083 /* there are `for' subclauses without stuff in the prologue */
1090 cl_loop_perform_for_pro(cl_loop_for_clause_t *fc)
1092 if (fc->depth == 1) {
1093 /* optimise for the trivial case */
1094 cl_loop_perform_for_pro_i(fc);
1095 cl_loop_perform_for_pro_b(fc);
1100 cl_loop_perform_for_pro_i(fc);
1102 while (!NILP(tra)) {
1103 cl_loop_for_clause_t *fct = get_dynacat(tra);
1104 cl_loop_perform_for_pro_i(fct);
1108 /* now specbind them */
1109 cl_loop_perform_for_pro_b(fc);
1111 while (!NILP(tra)) {
1112 cl_loop_for_clause_t *fct = get_dynacat(tra);
1113 cl_loop_perform_for_pro_b(fct);
1120 cl_loop_perform_for_i(cl_loop_for_clause_t *fc)
1122 /* non stepping stuff */
1123 switch (fc->for_subclause) {
1124 case FOR_EQUALS_THEN_CLAUSE:
1125 if (fc->counter++) {
1126 cl_loop_destructuring_bind(
1127 (cl_loop_binder_f)Fset, fc->form1,
1128 fc->curval = Feval(fc->then));
1131 case FOR_INVALID_CLAUSE:
1132 case FOR_ARITHMETIC_CLAUSE:
1133 case FOR_IN_SUBLIST_CLAUSE:
1134 case FOR_ON_SUBLIST_CLAUSE:
1135 case FOR_ACROSS_ARRAY_CLAUSE:
1136 case FOR_OF_HASHTABLE_CLAUSE:
1144 cl_loop_perform_for_b(cl_loop_for_clause_t *fc)
1146 switch (fc->for_subclause) {
1147 case FOR_ARITHMETIC_CLAUSE:
1148 case FOR_IN_SUBLIST_CLAUSE:
1149 case FOR_ON_SUBLIST_CLAUSE:
1150 case FOR_ACROSS_ARRAY_CLAUSE:
1151 /* bind to the value computed during the last iteration */
1152 cl_loop_destructuring_bind(
1153 (cl_loop_binder_f)Fset, fc->form1, fc->curval);
1154 case FOR_INVALID_CLAUSE:
1155 case FOR_OF_HASHTABLE_CLAUSE:
1156 case FOR_EQUALS_THEN_CLAUSE:
1161 /* most clauses step in this fun */
1162 switch (fc->for_subclause) {
1163 case FOR_EQUALS_THEN_CLAUSE:
1165 case FOR_ARITHMETIC_CLAUSE:
1166 fc->curval = ent_binop(fc->byop, fc->curval, fc->curstep);
1167 if (!fc->torel_strictp) {
1168 return ent_binrel2(fc->torel, ASE_BINARY_REL_EQUALP,
1169 fc->curval, fc->curbound);
1171 return ent_binrel(fc->torel, fc->curval, fc->curbound);
1174 case FOR_IN_SUBLIST_CLAUSE:
1175 /* error handling here, make sure curbound is a cons */
1176 fc->curbound = XCDR(fc->curbound);
1177 if (NILP(fc->curbound))
1179 fc->curval = XCAR(fc->curbound);
1182 case FOR_ON_SUBLIST_CLAUSE:
1183 /* error handling here, make sure curbound is a cons */
1184 if (NILP(fc->curval = XCDR(fc->curval)))
1188 case FOR_ACROSS_ARRAY_CLAUSE:
1190 if (fc->counter >= fc->bound)
1192 fc->curval = Faref(fc->curbound, make_int(fc->counter));
1195 case FOR_OF_HASHTABLE_CLAUSE: {
1196 hentry_t e = fc->ptr1;
1200 if (!NILP(fc->hash_keyvar)) {
1201 cl_loop_destructuring_bind(
1202 (cl_loop_binder_f)Fset,
1203 fc->hash_keyvar, e->key);
1205 if (!NILP(fc->hash_valvar)) {
1206 cl_loop_destructuring_bind(
1207 (cl_loop_binder_f)Fset,
1208 fc->hash_valvar, e->value);
1210 fc->ptr1 = cl_loop_next_hentry(e, XHASH_TABLE(fc->curbound));
1213 case FOR_INVALID_CLAUSE:
1221 cl_loop_perform_for(cl_loop_for_clause_t *fc)
1223 if (fc->depth == 1) {
1224 /* optimise for the trivial case */
1225 cl_loop_perform_for_i(fc);
1226 return cl_loop_perform_for_b(fc);
1231 cl_loop_perform_for_i(fc);
1233 while (!NILP(tra)) {
1234 cl_loop_for_clause_t *fct = get_dynacat(tra);
1235 cl_loop_perform_for_i(fct);
1239 /* now specbind them */
1240 state = cl_loop_perform_for_b(fc);
1242 while (!NILP(tra)) {
1243 cl_loop_for_clause_t *fct = get_dynacat(tra);
1244 state &= cl_loop_perform_for_b(fct);
1252 cl_loop_perform_do(cl_loop_do_clause_t *dc)
1259 cl_loop_perform_repeat(cl_loop_repeat_clause_t *rc)
1261 if (--rc->counter > 0) {
1268 cl_loop_perform_collect(cl_loop_accu_clause_t *ac)
1271 ac->cur = XCDR(ac->cur) = Fcons(Feval(ac->form), Qnil);
1273 Fset(ac->into, ac->cur = Fcons(Feval(ac->form), Qnil));
1279 cl_loop_perform_append(cl_loop_accu_clause_t *ac)
1281 Lisp_Object form = Feval(ac->form);
1284 XCDR(ac->cur) = form;
1286 Fset(ac->into, ac->cur = form);
1288 while (!NILP(XCDR(ac->cur)) && CONSP(XCDR(ac->cur)))
1289 ac->cur = XCDR(ac->cur);
1290 if (CONSP(ac->cur) && NILP(XCDR(ac->cur)))
1293 return wrong_type_argument(Qlistp, form);
1297 cl_loop_perform_nconc(cl_loop_accu_clause_t *ac)
1299 Lisp_Object form = Feval(ac->form);
1300 if (!NILP(ac->cur) && CONSP(ac->cur)) {
1301 XCDR(ac->cur) = form;
1303 Fset(ac->into, ac->cur = form);
1305 while (CONSP(ac->cur) &&
1306 !NILP(XCDR(ac->cur)) &&
1307 CONSP(XCDR(ac->cur)))
1308 ac->cur = XCDR(ac->cur);
1313 cl_loop_perform_count(cl_loop_accu_clause_t *ac)
1315 if (!NILP(Feval(ac->form))) {
1316 Fset(ac->into, ac->cur = make_int(XINT(ac->cur)+1));
1322 cl_loop_perform_sum(cl_loop_accu_clause_t *ac)
1324 Lisp_Object form = Feval(ac->form);
1327 ac->cur = ent_binop(ASE_BINARY_OP_SUM, ac->cur, form));
1332 cl_loop_perform_maximise(cl_loop_accu_clause_t *ac)
1334 Lisp_Object form = Feval(ac->form);
1336 if (ent_binrel(ASE_BINARY_REL_GREATERP, form, ac->cur))
1337 Fset(ac->into, ac->cur = form);
1342 cl_loop_perform_minimise(cl_loop_accu_clause_t *ac)
1344 Lisp_Object form = Feval(ac->form);
1346 if (ent_binrel(ASE_BINARY_REL_LESSP, form, ac->cur))
1347 Fset(ac->into, ac->cur = form);
1351 static inline Lisp_Object
1352 cl_loop_perform_accu_epi()
1353 __attribute__((always_inline));
1354 static inline Lisp_Object
1355 cl_loop_perform_accu_epi(
1356 Lisp_Object *SXE_UNUSED(result), cl_loop_accu_clause_t *ac)
1358 return symbol_value(XSYMBOL(ac->into));
1361 static inline Lisp_Object
1362 cl_loop_perform_finally_epi()
1363 __attribute__((always_inline));
1364 static inline Lisp_Object
1365 cl_loop_perform_finally_epi(
1366 Lisp_Object *SXE_UNUSED(result), cl_loop_inifinret_clause_t *rc)
1368 return Feval(rc->form);
1371 static inline Lisp_Object
1372 cl_loop_perform_return_epi()
1373 __attribute__((always_inline));
1374 static inline Lisp_Object
1375 cl_loop_perform_return_epi(
1376 Lisp_Object *result, cl_loop_inifinret_clause_t *rc)
1378 return *result = Feval(rc->form);
1383 cl_loop_prologue(Lisp_Object clause)
1387 emp = get_dynacat(clause);
1388 if (EQ(get_dynacat_type(clause), Qcl_loop_repeat_clause)) {
1389 cl_loop_perform_repeat_pro(emp);
1392 if (EQ(get_dynacat_type(clause), Qcl_loop_for_clause)) {
1393 cl_loop_perform_for_pro(emp);
1396 if (EQ(get_dynacat_type(clause), Qcl_loop_with_clause)) {
1397 cl_loop_perform_with_pro(emp);
1400 if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause)) {
1401 cl_loop_perform_colappnco_pro(emp);
1404 if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1405 cl_loop_perform_colappnco_pro(emp);
1408 if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1409 cl_loop_perform_colappnco_pro(emp);
1412 if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1413 cl_loop_perform_countsum_pro(emp);
1416 if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1417 cl_loop_perform_countsum_pro(emp);
1420 if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1421 cl_loop_perform_maximise_pro(emp);
1424 if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1425 cl_loop_perform_minimise_pro(emp);
1428 if (EQ(get_dynacat_type(clause), Qcl_loop_initially_clause)) {
1429 cl_loop_perform_initially_pro(emp);
1437 cl_loop_epilogue(Lisp_Object *result, Lisp_Object clause)
1441 emp = get_dynacat(clause);
1442 if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause)) {
1443 return cl_loop_perform_accu_epi(result, emp);
1445 if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause)) {
1446 return cl_loop_perform_accu_epi(result, emp);
1448 if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause)) {
1449 return cl_loop_perform_accu_epi(result, emp);
1451 if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause)) {
1452 return cl_loop_perform_accu_epi(result, emp);
1454 if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause)) {
1455 return cl_loop_perform_accu_epi(result, emp);
1457 if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause)) {
1458 return cl_loop_perform_accu_epi(result, emp);
1460 if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause)) {
1461 return cl_loop_perform_accu_epi(result, emp);
1463 if (EQ(get_dynacat_type(clause), Qcl_loop_return_clause)) {
1464 return cl_loop_perform_return_epi(result, emp);
1466 if (EQ(get_dynacat_type(clause), Qcl_loop_finally_clause)) {
1467 return cl_loop_perform_finally_epi(result, emp);
1469 return Qnull_pointer;
1473 cl_loop_iteration(Lisp_Object clause)
1477 emp = get_dynacat(clause);
1478 if (EQ(get_dynacat_type(clause), Qcl_loop_repeat_clause))
1479 return cl_loop_perform_repeat(emp);
1480 if (EQ(get_dynacat_type(clause), Qcl_loop_for_clause))
1481 return cl_loop_perform_for(emp);
1482 if (EQ(get_dynacat_type(clause), Qcl_loop_do_clause))
1483 return cl_loop_perform_do(emp);
1484 if (EQ(get_dynacat_type(clause), Qcl_loop_collect_clause))
1485 return cl_loop_perform_collect(emp);
1486 if (EQ(get_dynacat_type(clause), Qcl_loop_append_clause))
1487 return cl_loop_perform_append(emp);
1488 if (EQ(get_dynacat_type(clause), Qcl_loop_nconc_clause))
1489 return cl_loop_perform_nconc(emp);
1490 if (EQ(get_dynacat_type(clause), Qcl_loop_count_clause))
1491 return cl_loop_perform_count(emp);
1492 if (EQ(get_dynacat_type(clause), Qcl_loop_sum_clause))
1493 return cl_loop_perform_sum(emp);
1494 if (EQ(get_dynacat_type(clause), Qcl_loop_maximise_clause))
1495 return cl_loop_perform_maximise(emp);
1496 if (EQ(get_dynacat_type(clause), Qcl_loop_minimise_clause))
1497 return cl_loop_perform_minimise(emp);
1503 cl_loop_dllist_map(int(*fun)(Lisp_Object), dllist_t dll)
1506 dllist_item_t item = dllist_first(dll);
1514 state &= fun((Lisp_Object)item->item);
1521 cl_loop_dllist_map_return(
1522 Lisp_Object *result,
1523 Lisp_Object(*fun)(Lisp_Object*, Lisp_Object), dllist_t dll)
1526 dllist_item_t item = dllist_first(dll);
1527 Lisp_Object ret = Qnil;
1535 ret = fun(result, (Lisp_Object)item->item);
1538 if (!EQ(ret, Qnull_pointer))
1545 cl_loop_perform(cl_loop_sentence_t *lsen)
1547 dllist_t pro = XDLLIST(lsen->prologue);
1548 dllist_t epi = XDLLIST(lsen->epilogue);
1549 dllist_t iter = XDLLIST(lsen->iteration);
1550 int speccount = specpdl_depth();
1555 /* traverse the prologue */
1556 cl_loop_dllist_map(cl_loop_prologue, pro);
1557 /* traverse the iteration */
1558 while (lsen->state) {
1560 lsen->state = cl_loop_dllist_map(cl_loop_iteration, iter);
1562 /* traverse the epilogue */
1563 lsen->result = Qnull_pointer;
1564 res = cl_loop_dllist_map_return(&lsen->result, cl_loop_epilogue, epi);
1566 unbind_to(speccount, Qnil);
1568 return lsen->result;
1575 DEFUN("cl:loop-sentence", Fcl_loop_sentence, 0, UNEVALLED, 0, /*
1576 The Common Lisp loop macro.
1580 Lisp_Object loop_sentence = cl_loop_make_sentence();
1581 Lisp_Object context = Qnil, token = Qnil;
1582 cl_loop_sentence_t *lsen = get_dynacat(loop_sentence);
1584 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
1586 GCPRO4(args, loop_sentence, context, token);
1588 /* now parse the stuff */
1589 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 */