← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to o/iteration.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/iteration.c
 
1
/*
 
2
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
3
 
 
4
This file is part of GNU Common Lisp, herein referred to as GCL
 
5
 
 
6
GCL is free software; you can redistribute it and/or modify it under
 
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
8
the Free Software Foundation; either version 2, or (at your option)
 
9
any later version.
 
10
 
 
11
GCL is distributed in the hope that it will be useful, but WITHOUT
 
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
13
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
14
License for more details.
 
15
 
 
16
You should have received a copy of the GNU Library General Public License 
 
17
along with GCL; see the file COPYING.  If not, write to the Free Software
 
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
 
 
20
*/
 
21
 
 
22
/*
 
23
 
 
24
        iteration.c
 
25
 
 
26
*/
 
27
 
 
28
#include "include.h"
 
29
 
 
30
Floop(form)
 
31
object form;
 
32
{
 
33
        object endp_temp;
 
34
 
 
35
        object x;
 
36
        object *oldlex = lex_env;
 
37
        object id;
 
38
        object *top;
 
39
 
 
40
        make_nil_block();
 
41
 
 
42
        if (nlj_active) {
 
43
                nlj_active = FALSE;
 
44
                frs_pop();
 
45
                lex_env = oldlex;
 
46
                return;
 
47
        }
 
48
 
 
49
        top = vs_top;
 
50
 
 
51
        for(x = form; !endp(x); x = MMcdr(x)) {
 
52
                vs_top = top;
 
53
                eval(MMcar(x));
 
54
        }
 
55
LOOP:
 
56
        /*  Just !endp(x) is replaced by x != Cnil.  */
 
57
        for(x = form;  x != Cnil;  x = MMcdr(x)) {
 
58
                vs_top = top;
 
59
                eval(MMcar(x));
 
60
        }
 
61
        goto LOOP;
 
62
}
 
63
 
 
64
/*
 
65
        use of VS in Fdo and FdoA:
 
66
                        |       |
 
67
             lex_env -> | lex1  |
 
68
                        | lex2  |
 
69
                        | lex3  |
 
70
             start ->   |-------|       where each bt is a bind_temp:
 
71
                        |  bt1  |
 
72
                        |-------|       |  var  | -- name of DO variable
 
73
                            :           |  spp  | -- T if special
 
74
                        |-------|       | init  |
 
75
                        |  btn  |       |  aux  | -- step-form or var (if no
 
76
                        |-------|                    step-form is given)
 
77
             end ->     | body  |
 
78
             old_top->  |-------|       If 'spp' != T, it is NIL during
 
79
                                        initialization, and is the pointer to
 
80
                                        (var value) in lexical environment
 
81
                                        during the main loop.
 
82
*/
 
83
 
 
84
do_var_list(var_list)
 
85
object var_list;
 
86
{
 
87
        object endp_temp;
 
88
 
 
89
        object is, x, y;
 
90
 
 
91
        for (is = var_list;  !endp(is);  is = MMcdr(is)) {
 
92
                x = MMcar(is);
 
93
           if (type_of(x)==t_symbol)
 
94
               {vs_push(x);vs_push(Cnil);vs_push(Cnil);vs_push(x);
 
95
                continue;}
 
96
   
 
97
 
 
98
          
 
99
 
 
100
 
 
101
                if (type_of(x) != t_cons)
 
102
                        FEinvalid_form("The index, ~S, is illegal.", x);
 
103
                y = MMcar(x);
 
104
                check_var(y);
 
105
                vs_push(y);
 
106
                vs_push(Cnil);
 
107
                if (endp(MMcdr(x))) {
 
108
                        vs_push(Cnil);
 
109
                        vs_push(y);
 
110
                } else {
 
111
                        x = MMcdr(x);
 
112
                        vs_push(MMcar(x));
 
113
                        if (endp(MMcdr(x)))
 
114
                                vs_push(y);
 
115
                        else {
 
116
                                x = MMcdr(x);
 
117
                                vs_push(MMcar(x));
 
118
                                if (!endp(MMcdr(x)))
 
119
                                    FEerror("Too many forms to the index ~S.",
 
120
                                            1, y);
 
121
                        }
 
122
                }
 
123
        }
 
124
}
 
125
 
 
126
Fdo(arg)
 
127
object arg;
 
128
{
 
129
        object endp_temp;
 
130
 
 
131
        object *oldlex = lex_env;
 
132
        object *old_top;
 
133
        struct bind_temp *start, *end, *bt;
 
134
        object end_test, body;
 
135
        VOL object result;
 
136
        bds_ptr old_bds_top = bds_top;
 
137
 
 
138
        if (endp(arg) || endp(MMcdr(arg)))
 
139
                FEtoo_few_argumentsF(arg);
 
140
        if (endp(MMcadr(arg)))
 
141
                FEinvalid_form("The DO end-test, ~S, is illegal.",
 
142
                                MMcadr(arg));
 
143
 
 
144
        end_test = MMcaadr(arg);
 
145
        result = MMcdadr(arg);
 
146
 
 
147
        make_nil_block();
 
148
 
 
149
        if (nlj_active) {
 
150
                nlj_active = FALSE;
 
151
                goto END;
 
152
        }
 
153
 
 
154
        start = (struct bind_temp *) vs_top;
 
155
 
 
156
        do_var_list(MMcar(arg));
 
157
        end = (struct bind_temp *)vs_top;
 
158
        body = let_bind(MMcddr(arg), start, end);
 
159
        vs_push(body);
 
160
 
 
161
        for (bt = start;  bt < end;  bt++)
 
162
                if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
 
163
                        bt->bt_spp = Ct;
 
164
                else if (bt->bt_spp == Cnil)
 
165
                        bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
 
166
 
 
167
        old_top = vs_top;
 
168
 
 
169
LOOP:   /* the main loop */
 
170
        vs_top = old_top;
 
171
        eval(end_test);
 
172
        if (vs_base[0] != Cnil) {
 
173
                /* RESULT evaluation */
 
174
                if (endp(result)) {
 
175
                        vs_base = vs_top = old_top;
 
176
                        vs_push(Cnil);
 
177
                } else
 
178
                        do {
 
179
                                vs_top = old_top;
 
180
                                eval(MMcar(result));
 
181
                                result = MMcdr(result);
 
182
                        } while (!endp(result));
 
183
                goto END;
 
184
        }
 
185
 
 
186
        vs_top = old_top;
 
187
 
 
188
        Ftagbody(body);
 
189
 
 
190
        /* next step */
 
191
        for (bt = start;  bt<end;  bt++) {
 
192
                if (bt->bt_aux != bt->bt_var) {
 
193
                        eval_assign(bt->bt_init, bt->bt_aux);
 
194
                }
 
195
        }
 
196
        for (bt = start;  bt<end;  bt++) {
 
197
                if (bt->bt_aux != bt->bt_var)
 
198
                        if (bt->bt_spp == Ct)
 
199
                                bt->bt_var->s.s_dbind = bt->bt_init;
 
200
                        else
 
201
                                MMcadr(bt->bt_spp) = bt->bt_init;
 
202
        }
 
203
        goto LOOP;
 
204
 
 
205
END:
 
206
        bds_unwind(old_bds_top);
 
207
        frs_pop();
 
208
        lex_env = oldlex;
 
209
}
 
210
 
 
211
FdoA(arg)
 
212
object arg;
 
213
{
 
214
        object endp_temp;
 
215
 
 
216
        object *oldlex = lex_env;
 
217
        object *old_top;
 
218
        struct bind_temp *start, *end, *bt;
 
219
        object end_test, body;
 
220
        VOL object result;
 
221
        bds_ptr old_bds_top = bds_top;
 
222
 
 
223
        if (endp(arg) || endp(MMcdr(arg)))
 
224
                FEtoo_few_argumentsF(arg);
 
225
        if (endp(MMcadr(arg)))
 
226
                FEinvalid_form("The DO* end-test, ~S, is illegal.",
 
227
                                MMcadr(arg));
 
228
 
 
229
        end_test = MMcaadr(arg);
 
230
        result = MMcdadr(arg);
 
231
 
 
232
        make_nil_block();
 
233
 
 
234
        if (nlj_active) {
 
235
                nlj_active = FALSE;
 
236
                goto END;
 
237
        }
 
238
 
 
239
        start = (struct bind_temp *)vs_top;
 
240
        do_var_list(MMcar(arg));
 
241
        end = (struct bind_temp *)vs_top;
 
242
        body = letA_bind(MMcddr(arg), start, end);
 
243
        vs_push(body);
 
244
 
 
245
        for (bt = start;  bt < end;  bt++)
 
246
                if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
 
247
                        bt->bt_spp = Ct;
 
248
                else if (bt->bt_spp == Cnil)
 
249
                        bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
 
250
 
 
251
        old_top = vs_top;
 
252
 
 
253
LOOP:   /* the main loop */
 
254
        eval(end_test);
 
255
        if (vs_base[0] != Cnil) {
 
256
                /* RESULT evaluation */
 
257
                if (endp(result)) {
 
258
                        vs_base = vs_top = old_top;
 
259
                        vs_push(Cnil);
 
260
                } else
 
261
                        do {
 
262
                                vs_top = old_top;
 
263
                                eval(MMcar(result));
 
264
                                result = MMcdr(result);
 
265
                        } while (!endp(result));
 
266
                goto END;
 
267
        }
 
268
 
 
269
        vs_top = old_top;
 
270
 
 
271
        Ftagbody(body);
 
272
 
 
273
        /* next step */
 
274
        for (bt = start;  bt < end;  bt++)
 
275
                if (bt->bt_aux != bt->bt_var) {
 
276
                        if (bt->bt_spp == Ct) {
 
277
                            eval_assign(bt->bt_var->s.s_dbind, bt->bt_aux);
 
278
                        } else {
 
279
                            eval_assign(MMcadr(bt->bt_spp), bt->bt_aux);
 
280
                        }
 
281
                }
 
282
        goto LOOP;
 
283
 
 
284
END:
 
285
        bds_unwind(old_bds_top);
 
286
        frs_pop();
 
287
        lex_env = oldlex;
 
288
}
 
289
 
 
290
Fdolist(arg)
 
291
object arg;
 
292
{
 
293
        object endp_temp;
 
294
 
 
295
        object *oldlex = lex_env;
 
296
        object *old_top;
 
297
        struct bind_temp *start;
 
298
        object x, listform, body;
 
299
        VOL object result;
 
300
        bds_ptr old_bds_top = bds_top;
 
301
 
 
302
        if (endp(arg))
 
303
                FEtoo_few_argumentsF(arg);
 
304
 
 
305
        x = MMcar(arg);
 
306
        if (endp(x))
 
307
                FEerror("No variable.", 0);
 
308
        start = (struct bind_temp *)vs_top;
 
309
        vs_push(MMcar(x));
 
310
        vs_push(Cnil);
 
311
        vs_push(Cnil);
 
312
        vs_push(Cnil);
 
313
        x = MMcdr(x);
 
314
        if (endp(x))
 
315
                FEerror("No listform.", 0);
 
316
        listform = MMcar(x);
 
317
        x = MMcdr(x);
 
318
        if (endp(x))
 
319
                result = Cnil;
 
320
        else {
 
321
                result = MMcar(x);
 
322
                if (!endp(MMcdr(x)))
 
323
                        FEerror("Too many resultforms.", 0);
 
324
        }
 
325
 
 
326
        make_nil_block();
 
327
 
 
328
        if (nlj_active) {
 
329
                nlj_active = FALSE;
 
330
                goto END;
 
331
        }
 
332
 
 
333
        eval_assign(start->bt_init, listform);
 
334
        body = find_special(MMcdr(arg), start, start+1);
 
335
        vs_push(body);
 
336
        bind_var(start->bt_var, Cnil, start->bt_spp);
 
337
        if ((enum stype)start->bt_var->s.s_stype != stp_ordinary)
 
338
                start->bt_spp = Ct;
 
339
        else if (start->bt_spp == Cnil)
 
340
                start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
 
341
 
 
342
        old_top = vs_top;
 
343
 
 
344
LOOP:   /* the main loop */
 
345
        if (endp(start->bt_init)) {
 
346
                if (start->bt_spp == Ct)
 
347
                        start->bt_var->s.s_dbind = Cnil;
 
348
                else
 
349
                        MMcadr(start->bt_spp) = Cnil;
 
350
                eval(result);
 
351
                goto END;
 
352
        }
 
353
 
 
354
        if (start->bt_spp == Ct)
 
355
                start->bt_var->s.s_dbind = MMcar(start->bt_init);
 
356
        else
 
357
                MMcadr(start->bt_spp) = MMcar(start->bt_init);
 
358
        start->bt_init = MMcdr(start->bt_init);
 
359
 
 
360
        vs_top = old_top;
 
361
 
 
362
        Ftagbody(body);
 
363
 
 
364
        goto LOOP;
 
365
 
 
366
END:
 
367
        bds_unwind(old_bds_top);
 
368
        frs_pop();
 
369
        lex_env = oldlex;
 
370
}
 
371
 
 
372
Fdotimes(arg)
 
373
object arg;
 
374
{
 
375
        object endp_temp;
 
376
 
 
377
        object *oldlex = lex_env;
 
378
        object *old_top;
 
379
        struct bind_temp *start;
 
380
        object x, countform, body;
 
381
        VOL object result;
 
382
        bds_ptr old_bds_top = bds_top;
 
383
 
 
384
        if (endp(arg))
 
385
                FEtoo_few_argumentsF(arg);
 
386
 
 
387
        x = MMcar(arg);
 
388
        if (endp(x))
 
389
                FEerror("No variable.", 0);
 
390
        start = (struct bind_temp *)vs_top;
 
391
        vs_push(MMcar(x));
 
392
        vs_push(Cnil);
 
393
        vs_push(Cnil);
 
394
        vs_push(Cnil);
 
395
        x = MMcdr(x);
 
396
        if (endp(x))
 
397
                FEerror("No countform.", 0);
 
398
        countform = MMcar(x);
 
399
        x = MMcdr(x);
 
400
        if (endp(x))
 
401
                result = Cnil;
 
402
        else {
 
403
                result = MMcar(x);
 
404
                if (!endp(MMcdr(x)))
 
405
                        FEerror("Too many resultforms.", 0);
 
406
        }
 
407
 
 
408
        make_nil_block();
 
409
 
 
410
        if (nlj_active) {
 
411
                nlj_active = FALSE;
 
412
                goto END;
 
413
        }
 
414
 
 
415
        eval_assign(start->bt_init, countform);
 
416
        if (type_of(start->bt_init) != t_fixnum &&
 
417
            type_of(start->bt_init) != t_bignum)
 
418
                FEwrong_type_argument(sLinteger, start->bt_init);
 
419
        body = find_special(MMcdr(arg), start, start+1);
 
420
        vs_push(body);
 
421
        bind_var(start->bt_var, make_fixnum(0), start->bt_spp);
 
422
        if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) {
 
423
                start->bt_spp = Ct;
 
424
                x = start->bt_var->s.s_dbind;
 
425
        } else if (start->bt_spp == Cnil) {
 
426
                start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
 
427
                x = MMcadr(start->bt_spp);
 
428
        } else
 
429
                x = start->bt_var->s.s_dbind;
 
430
 
 
431
        old_top = vs_top;
 
432
 
 
433
LOOP:   /* the main loop */
 
434
        if (number_compare(x, start->bt_init) >= 0) {
 
435
                eval(result);
 
436
                goto END;
 
437
        }
 
438
 
 
439
        vs_top = old_top;
 
440
 
 
441
        Ftagbody(body);
 
442
 
 
443
        if (start->bt_spp == Ct)
 
444
                x = start->bt_var->s.s_dbind = one_plus(x);
 
445
        else
 
446
                x = MMcadr(start->bt_spp) = one_plus(x);
 
447
 
 
448
        goto LOOP;
 
449
 
 
450
END:
 
451
        bds_unwind(old_bds_top);
 
452
        frs_pop();
 
453
        lex_env = oldlex;
 
454
}
 
455
 
 
456
init_iteration()
 
457
{
 
458
        make_special_form("LOOP", Floop);
 
459
        make_special_form("DO", Fdo);
 
460
        make_special_form("DO*", FdoA);
 
461
        make_special_form("DOLIST", Fdolist);
 
462
        make_special_form("DOTIMES", Fdotimes);
 
463
}