← Back to branch summary

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

« back to all changes in this revision

Viewing changes to .pc/2.6.10pre-test-6/o/bind.c

  • Committer: Package Import Robot
  • Author(s): Camm Maguire
  • Date: 2013-11-13 18:39:19 UTC
  • mfrom: (13.1.102 sid)
  • Revision ID: package-import@ubuntu.com-20131113183919-cs74swffevkpkp1l
Tags: 2.6.10-1
New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/2.6.10pre-test-6/o/bind.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
 
        bind.c
24
 
*/
25
 
 
26
 
#include "include.h"
27
 
#include <string.h>
28
 
 
29
 
static void
30
 
illegal_lambda(void);
31
 
 
32
 
 
33
 
struct nil3 { object nil3_self[3]; } three_nils;
34
 
struct nil6 { object nil6_self[6]; } six_nils;
35
 
 
36
 
struct required {
37
 
        object  req_var;
38
 
        object  req_spp;
39
 
};
40
 
 
41
 
struct optional {
42
 
        object  opt_var;
43
 
        object  opt_spp;
44
 
        object  opt_init;
45
 
        object  opt_svar;
46
 
        object  opt_svar_spp;
47
 
};
48
 
 
49
 
struct rest {
50
 
        object  rest_var;
51
 
        object  rest_spp;
52
 
};
53
 
 
54
 
struct keyword {
55
 
        object  key_word;
56
 
        object  key_var;
57
 
        object  key_spp;
58
 
        object  key_init;
59
 
        object  key_svar;
60
 
        object  key_svar_spp;
61
 
        object  key_val;
62
 
        object  key_svar_val;
63
 
};
64
 
 
65
 
struct aux {
66
 
        object  aux_var;
67
 
        object  aux_spp;
68
 
        object  aux_init;
69
 
};
70
 
 
71
 
 
72
 
 
73
 
 
74
 
 
75
 
#define isdeclare(x)    ((x) == sLdeclare)
76
 
 
77
 
void
78
 
lambda_bind(object *arg_top)
79
 
{
80
 
  
81
 
        object temporary;
82
 
        object lambda, lambda_list, body, form=Cnil, x, ds, vs, v;
83
 
        int narg, i, j;
84
 
        object *base = vs_base;
85
 
        struct required *required;
86
 
        int nreq;
87
 
        struct optional *optional=NULL;
88
 
        int nopt;
89
 
        struct rest *rest=NULL;
90
 
        bool rest_flag;
91
 
        struct keyword *keyword=NULL;
92
 
        bool key_flag;
93
 
        bool allow_other_keys_flag, other_keys_appeared;
94
 
        int nkey;
95
 
        struct aux *aux=NULL;
96
 
        int naux;
97
 
        bool special_processed;
98
 
        vs_mark;
99
 
 
100
 
        bds_check;
101
 
        lambda = vs_head;
102
 
        if (type_of(lambda) != t_cons)
103
 
                FEerror("No lambda list.", 0);
104
 
        lambda_list = lambda->c.c_car;
105
 
        body = lambda->c.c_cdr;
106
 
 
107
 
        required = (struct required *)vs_top;
108
 
        nreq = 0;
109
 
        for (;;) {
110
 
                if (endp(lambda_list))
111
 
                        goto REQUIRED_ONLY;
112
 
                x = lambda_list->c.c_car;
113
 
                lambda_list = lambda_list->c.c_cdr;
114
 
                check_symbol(x);
115
 
                if (x == ANDallow_other_keys)
116
 
                        illegal_lambda();
117
 
                if (x == ANDoptional) {
118
 
                        nopt = nkey = naux = 0;
119
 
                        rest_flag = key_flag = allow_other_keys_flag
120
 
                        = FALSE;
121
 
                        goto OPTIONAL;
122
 
                }
123
 
                if (x == ANDrest) {
124
 
                        nopt = nkey = naux = 0;
125
 
                        key_flag = allow_other_keys_flag
126
 
                        = FALSE;
127
 
                        goto REST;
128
 
                }
129
 
                if (x == ANDkey) {
130
 
                        nopt = nkey = naux = 0;
131
 
                        rest_flag = allow_other_keys_flag
132
 
                        = FALSE;
133
 
                        goto KEYWORD;
134
 
                }
135
 
                if (x == ANDaux) {
136
 
                        nopt = nkey = naux = 0;
137
 
                        rest_flag = key_flag = allow_other_keys_flag
138
 
                        = FALSE;
139
 
                        goto AUX_L;
140
 
                }
141
 
                if ((enum stype)x->s.s_stype == stp_constant)
142
 
                        FEerror("~S is not a variable.", 1, x);
143
 
                vs_push(x);
144
 
                vs_push(Cnil);
145
 
                nreq++;
146
 
        }
147
 
 
148
 
OPTIONAL:
149
 
        optional = (struct optional *)vs_top;
150
 
        for (;;  nopt++) {
151
 
                if (endp(lambda_list))
152
 
                        goto SEARCH_DECLARE;
153
 
                x = lambda_list->c.c_car;
154
 
                lambda_list = lambda_list->c.c_cdr;
155
 
                if (type_of(x) == t_cons) {
156
 
                        check_symbol(x->c.c_car);
157
 
                        check_var(x->c.c_car);
158
 
                        vs_push(x->c.c_car);
159
 
                        x = x->c.c_cdr;
160
 
                        vs_push(Cnil);
161
 
                        if (endp(x)) {
162
 
                                *(struct nil3 *)vs_top = three_nils;
163
 
                                vs_top += 3;
164
 
                                continue;
165
 
                        }
166
 
                        vs_push(x->c.c_car);
167
 
                        x = x->c.c_cdr;
168
 
                        if (endp(x)) {
169
 
                                vs_push(Cnil);
170
 
                                vs_push(Cnil);
171
 
                                continue;
172
 
                        }
173
 
                        check_symbol(x->c.c_car);
174
 
                        check_var(x->c.c_car);
175
 
                        vs_push(x->c.c_car);
176
 
                        vs_push(Cnil);
177
 
                        if (!endp(x->c.c_cdr))
178
 
                                illegal_lambda();
179
 
                } else {
180
 
                        check_symbol(x);
181
 
                        if (x == ANDoptional ||
182
 
                            x == ANDallow_other_keys)
183
 
                                illegal_lambda();
184
 
                        if (x == ANDrest)
185
 
                                goto REST;
186
 
                        if (x == ANDkey)
187
 
                                goto KEYWORD;
188
 
                        if (x == ANDaux)
189
 
                                goto AUX_L;
190
 
                        check_var(x);
191
 
                        vs_push(x);
192
 
                        *(struct nil6 *)vs_top = six_nils;
193
 
                        vs_top += 4;
194
 
                }
195
 
        }
196
 
 
197
 
REST:
198
 
        rest = (struct rest *)vs_top;
199
 
        if (endp(lambda_list))
200
 
                illegal_lambda();
201
 
        check_symbol(lambda_list->c.c_car);
202
 
        check_var(lambda_list->c.c_car);
203
 
        rest_flag = TRUE;
204
 
        vs_push(lambda_list->c.c_car);
205
 
        vs_push(Cnil);
206
 
        lambda_list = lambda_list->c.c_cdr;
207
 
        if (endp(lambda_list))
208
 
                goto SEARCH_DECLARE;
209
 
        x = lambda_list->c.c_car;
210
 
        lambda_list = lambda_list->c.c_cdr;
211
 
        check_symbol(x);
212
 
        if (x == ANDoptional || x == ANDrest ||
213
 
            x == ANDallow_other_keys)
214
 
                illegal_lambda();
215
 
        if (x == ANDkey)
216
 
                goto KEYWORD;
217
 
        if (x == ANDaux)
218
 
                goto AUX_L;
219
 
        illegal_lambda();
220
 
 
221
 
KEYWORD:
222
 
        keyword = (struct keyword *)vs_top;
223
 
        key_flag = TRUE;
224
 
        for (;;  nkey++) {
225
 
                if (endp(lambda_list))
226
 
                        goto SEARCH_DECLARE;
227
 
                x = lambda_list->c.c_car;
228
 
                lambda_list = lambda_list->c.c_cdr;
229
 
                if (type_of(x) == t_cons) {
230
 
                        if (type_of(x->c.c_car) == t_cons) {
231
 
                                if (!keywordp(x->c.c_car->c.c_car))
232
 
                                  /* FIXME better message */
233
 
                                        FEunexpected_keyword(x->c.c_car->c.c_car);
234
 
                                vs_push(x->c.c_car->c.c_car);
235
 
                                if (endp(x->c.c_car->c.c_cdr))
236
 
                                        illegal_lambda();
237
 
                                check_symbol(x->c.c_car
238
 
                                              ->c.c_cdr->c.c_car);
239
 
                                vs_push(x->c.c_car->c.c_cdr->c.c_car);
240
 
                                if (!endp(x->c.c_car->c.c_cdr->c.c_cdr))
241
 
                                        illegal_lambda();
242
 
                        } else {
243
 
                                check_symbol(x->c.c_car);
244
 
                                check_var(x->c.c_car);
245
 
                                vs_push(intern(x->c.c_car, keyword_package));
246
 
                                vs_push(x->c.c_car);
247
 
                        }
248
 
                        vs_push(Cnil);
249
 
                        x = x->c.c_cdr;
250
 
                        if (endp(x)) {
251
 
                                *(struct nil6 *)vs_top = six_nils;
252
 
                                vs_top += 5;
253
 
                                continue;
254
 
                        }
255
 
                        vs_push(x->c.c_car);
256
 
                        x = x->c.c_cdr;
257
 
                        if (endp(x)) {
258
 
                                *(struct nil6 *)vs_top = six_nils;
259
 
                                vs_top += 4;
260
 
                                continue;
261
 
                        }
262
 
                        check_symbol(x->c.c_car);
263
 
                        check_var(x->c.c_car);
264
 
                        vs_push(x->c.c_car);
265
 
                        vs_push(Cnil);
266
 
                        if (!endp(x->c.c_cdr))
267
 
                                illegal_lambda();
268
 
                        vs_push(Cnil);
269
 
                        vs_push(Cnil);
270
 
                } else {
271
 
                        check_symbol(x);
272
 
                        if (x == ANDallow_other_keys) {
273
 
                                allow_other_keys_flag = TRUE;
274
 
                                if (endp(lambda_list))
275
 
                                        goto SEARCH_DECLARE;
276
 
                                x = lambda_list->c.c_car;
277
 
                                lambda_list = lambda_list->c.c_cdr;
278
 
                        }
279
 
                        if (x == ANDoptional || x == ANDrest ||
280
 
                            x == ANDkey || x == ANDallow_other_keys)
281
 
                                illegal_lambda();
282
 
                        if (x == ANDaux)
283
 
                                goto AUX_L;
284
 
                        check_var(x);
285
 
                        vs_push(intern(x, keyword_package));
286
 
                        vs_push(x);
287
 
                        *(struct nil6 *)vs_top = six_nils;
288
 
                        vs_top += 6;
289
 
                }
290
 
        }
291
 
 
292
 
AUX_L:
293
 
        aux = (struct aux *)vs_top;
294
 
        for (;;  naux++) {
295
 
                if (endp(lambda_list))
296
 
                        goto SEARCH_DECLARE;
297
 
                x = lambda_list->c.c_car;
298
 
                lambda_list = lambda_list->c.c_cdr;
299
 
                if (type_of(x) == t_cons) {
300
 
                        check_symbol(x->c.c_car);
301
 
                        check_var(x->c.c_car);
302
 
                        vs_push(x->c.c_car);
303
 
                        vs_push(Cnil);
304
 
                        x = x->c.c_cdr;
305
 
                        if (endp(x)) {
306
 
                                vs_push(Cnil);
307
 
                                continue;
308
 
                        }
309
 
                        vs_push(x->c.c_car);
310
 
                        if (!endp(x->c.c_cdr))
311
 
                                illegal_lambda();
312
 
                } else {
313
 
                        check_symbol(x);
314
 
                        if (x == ANDoptional || x == ANDrest ||
315
 
                            x == ANDkey || x == ANDallow_other_keys ||
316
 
                            x == ANDaux)
317
 
                                illegal_lambda();
318
 
                        check_var(x);
319
 
                        vs_push(x);
320
 
                        vs_push(Cnil);
321
 
                        vs_push(Cnil);
322
 
                }
323
 
        }
324
 
 
325
 
SEARCH_DECLARE:
326
 
        vs_push(Cnil);
327
 
        for (;  !endp(body);  body = body->c.c_cdr) {
328
 
                form = body->c.c_car;
329
 
 
330
 
                /*  MACRO EXPANSION  */
331
 
                form = macro_expand(form);
332
 
                vs_head = form;
333
 
 
334
 
                if (type_of(form) == t_string) {
335
 
                        if (endp(body->c.c_cdr))
336
 
                                break;
337
 
                        continue;
338
 
                }
339
 
                if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
340
 
                        break;
341
 
                for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
342
 
                        if (type_of(ds->c.c_car) != t_cons)
343
 
                                illegal_declare(form);
344
 
                        if (ds->c.c_car->c.c_car == sLspecial) {
345
 
                                vs = ds->c.c_car->c.c_cdr;
346
 
                                for (;  !endp(vs);  vs = vs->c.c_cdr) {
347
 
                                        v = vs->c.c_car;
348
 
                                        check_symbol(v);
349
 
/**/
350
 
 
351
 
        special_processed = FALSE;
352
 
        for (i = 0;  i < nreq;  i++)
353
 
                if (required[i].req_var == v) {
354
 
                        required[i].req_spp = Ct;
355
 
                        special_processed = TRUE;
356
 
                }
357
 
        for (i = 0;  i < nopt;  i++)
358
 
                if (optional[i].opt_var == v) {
359
 
                        optional[i].opt_spp = Ct;
360
 
                        special_processed = TRUE;
361
 
                } else if (optional[i].opt_svar == v) {
362
 
                        optional[i].opt_svar_spp = Ct;
363
 
                        special_processed = TRUE;
364
 
                }
365
 
        if (rest_flag && rest->rest_var == v) {
366
 
                rest->rest_spp = Ct;
367
 
                special_processed = TRUE;
368
 
        }
369
 
        for (i = 0;  i < nkey;  i++)
370
 
                if (keyword[i].key_var == v) {
371
 
                        keyword[i].key_spp = Ct;
372
 
                        special_processed = TRUE;
373
 
                } else if (keyword[i].key_svar == v) {
374
 
                        keyword[i].key_svar_spp = Ct;
375
 
                        special_processed = TRUE;
376
 
                }
377
 
        for (i = 0;  i < naux;  i++)
378
 
                if (aux[i].aux_var == v) {
379
 
                        aux[i].aux_spp = Ct;
380
 
                        special_processed = TRUE;
381
 
                }
382
 
        if (special_processed)
383
 
                continue;
384
 
        /*  lex_special_bind(v);  */
385
 
        lex_env[0] = MMcons(MMcons(v, Cnil), lex_env[0]);
386
 
 
387
 
/**/
388
 
                                }
389
 
                        }
390
 
                }
391
 
        }
392
 
 
393
 
        narg = arg_top - base;
394
 
        if (narg < nreq) {
395
 
                if (nopt == 0 && !rest_flag && !key_flag) {
396
 
                        vs_base = base;
397
 
                        vs_top = arg_top;
398
 
                        check_arg_failed(nreq);
399
 
                }
400
 
                FEtoo_few_arguments(base, arg_top);
401
 
        }
402
 
        if (!rest_flag && !key_flag && narg > nreq+nopt) {
403
 
                if (nopt == 0) {
404
 
                        vs_base = base;
405
 
                        vs_top = arg_top;
406
 
                        check_arg_failed(nreq);
407
 
                }
408
 
                FEtoo_many_arguments(base, arg_top);
409
 
        }
410
 
        for (i = 0;  i < nreq;  i++)
411
 
                bind_var(required[i].req_var,
412
 
                         base[i],
413
 
                         required[i].req_spp);
414
 
        for (i = 0;  i < nopt;  i++)
415
 
                if (nreq+i < narg) {
416
 
                        bind_var(optional[i].opt_var,
417
 
                                 base[nreq+i],
418
 
                                 optional[i].opt_spp);
419
 
                        if (optional[i].opt_svar != Cnil)
420
 
                                bind_var(optional[i].opt_svar,
421
 
                                         Ct,
422
 
                                         optional[i].opt_svar_spp);
423
 
                } else {
424
 
                        eval_assign(temporary, optional[i].opt_init);
425
 
                        bind_var(optional[i].opt_var,
426
 
                                 temporary,
427
 
                                 optional[i].opt_spp);
428
 
                        if (optional[i].opt_svar != Cnil)
429
 
                                bind_var(optional[i].opt_svar,
430
 
                                         Cnil,
431
 
                                         optional[i].opt_svar_spp);
432
 
                }
433
 
        if (rest_flag) {
434
 
                vs_push(Cnil);
435
 
                for (i = narg, j = nreq+nopt;  --i >= j;  )
436
 
                        vs_head = make_cons(base[i], vs_head);
437
 
                bind_var(rest->rest_var, vs_head, rest->rest_spp);
438
 
        }
439
 
        if (key_flag) {
440
 
                i = narg - nreq - nopt;
441
 
                if (i >= 0 && i%2 != 0)
442
 
                  /* FIXME better message */
443
 
                  FEunexpected_keyword(Cnil);
444
 
                other_keys_appeared = FALSE;
445
 
                for (i = nreq + nopt;  i < narg;  i += 2) {
446
 
                        if (!keywordp(base[i]))
447
 
                                FEunexpected_keyword(base[i]);
448
 
                        if (base[i] == sKallow_other_keys &&
449
 
                            base[i+1] != Cnil)
450
 
                                allow_other_keys_flag = TRUE;
451
 
                        for (j = 0;  j < nkey;  j++) {
452
 
                                if (keyword[j].key_word == base[i]) {
453
 
                                        if (keyword[j].key_svar_val
454
 
                                            != Cnil)
455
 
                                                goto NEXT_ARG;
456
 
                                        keyword[j].key_val
457
 
                                        = base[i+1];
458
 
                                        keyword[j].key_svar_val
459
 
                                        = Ct;
460
 
                                        goto NEXT_ARG;
461
 
                                }
462
 
                        }
463
 
                        other_keys_appeared = TRUE;
464
 
 
465
 
                NEXT_ARG:
466
 
                        continue;
467
 
                }
468
 
                if (other_keys_appeared && !allow_other_keys_flag)
469
 
                  /* FIXME better message */
470
 
                  FEunexpected_keyword(Ct);
471
 
        }
472
 
        for (i = 0;  i < nkey;  i++)
473
 
                if (keyword[i].key_svar_val != Cnil) {
474
 
                        bind_var(keyword[i].key_var,
475
 
                                 keyword[i].key_val,
476
 
                                 keyword[i].key_spp);
477
 
                        if (keyword[i].key_svar != Cnil)
478
 
                                bind_var(keyword[i].key_svar,
479
 
                                         keyword[i].key_svar_val,
480
 
                                         keyword[i].key_svar_spp);
481
 
                } else {
482
 
                        eval_assign(temporary, keyword[i].key_init);
483
 
                        bind_var(keyword[i].key_var,
484
 
                                 temporary,
485
 
                                 keyword[i].key_spp);
486
 
                        if (keyword[i].key_svar != Cnil)
487
 
                                bind_var(keyword[i].key_svar,
488
 
                                         keyword[i].key_svar_val,
489
 
                                         keyword[i].key_svar_spp);
490
 
                }
491
 
        for (i = 0;  i < naux;  i++) {
492
 
                eval_assign(temporary, aux[i].aux_init);
493
 
                bind_var(aux[i].aux_var, temporary, aux[i].aux_spp);
494
 
        }
495
 
        if (type_of(body) != t_cons || body->c.c_car == form) {
496
 
                vs_reset;
497
 
                vs_head = body;
498
 
        } else {
499
 
                body = make_cons(form, body->c.c_cdr);
500
 
                vs_reset;
501
 
                vs_head = body;
502
 
        }
503
 
        return;
504
 
 
505
 
REQUIRED_ONLY:
506
 
        vs_push(Cnil);
507
 
        for (;  !endp(body);  body = body->c.c_cdr) {
508
 
                form = body->c.c_car;
509
 
 
510
 
                /*  MACRO EXPANSION  */
511
 
                vs_head = form = macro_expand(form);
512
 
 
513
 
                if (type_of(form) == t_string) {
514
 
                        if (endp(body->c.c_cdr))
515
 
                                break;
516
 
                        continue;
517
 
                }
518
 
                if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
519
 
                        break;
520
 
                for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
521
 
                        if (type_of(ds->c.c_car) != t_cons)
522
 
                                illegal_declare(form);
523
 
                        if (ds->c.c_car->c.c_car == sLspecial) {
524
 
                                vs = ds->c.c_car->c.c_cdr;
525
 
                                for (;  !endp(vs);  vs = vs->c.c_cdr) {
526
 
                                        v = vs->c.c_car;
527
 
                                        check_symbol(v);
528
 
/**/
529
 
 
530
 
        special_processed = FALSE;
531
 
        for (i = 0;  i < nreq;  i++)
532
 
                if (required[i].req_var == v) {
533
 
                        required[i].req_spp = Ct;
534
 
                        special_processed = TRUE;
535
 
                }
536
 
        if (special_processed)
537
 
                continue;
538
 
        /*  lex_special_bind(v);  */
539
 
        temporary = MMcons(v, Cnil);
540
 
        lex_env[0] = MMcons(temporary, lex_env[0]);
541
 
 
542
 
/**/
543
 
                                }
544
 
                        }
545
 
                }
546
 
        }
547
 
 
548
 
        narg = arg_top - base;
549
 
        if (narg != nreq) {
550
 
                vs_base = base;
551
 
                vs_top = arg_top;
552
 
                check_arg_failed(nreq);
553
 
        }
554
 
        for (i = 0;  i < nreq;  i++)
555
 
                bind_var(required[i].req_var,
556
 
                         base[i],
557
 
                         required[i].req_spp);
558
 
        if (type_of(body) != t_cons || body->c.c_car == form) {
559
 
                vs_reset;
560
 
                vs_head = body;
561
 
        } else {
562
 
                body = make_cons(form, body->c.c_cdr);
563
 
                vs_reset;
564
 
                vs_head = body;
565
 
        }
566
 
}
567
 
 
568
 
void
569
 
bind_var(object var, object val, object spp)
570
 
{ 
571
 
        object temporary;
572
 
        vs_mark;
573
 
 
574
 
        switch (var->s.s_stype) {
575
 
        case stp_constant:
576
 
                FEerror("Cannot bind the constant ~S.", 1, var);
577
 
 
578
 
        case stp_special:
579
 
                bds_bind(var, val);
580
 
                break;
581
 
 
582
 
        default:
583
 
                if (spp != Cnil) {
584
 
                        /*  lex_special_bind(var);  */
585
 
                        temporary = MMcons(var, Cnil);
586
 
                        lex_env[0] = MMcons(temporary, lex_env[0]);
587
 
                        bds_bind(var, val);
588
 
                } else {
589
 
                        /*  lex_local_bind(var, val);  */
590
 
                        temporary = MMcons(val, Cnil);
591
 
                        temporary = MMcons(var, temporary);
592
 
                        lex_env[0] = MMcons(temporary, lex_env[0]);
593
 
                }
594
 
                break;
595
 
        }
596
 
        vs_reset;
597
 
}
598
 
 
599
 
static void
600
 
illegal_lambda(void)
601
 
{
602
 
        FEerror("Illegal lambda expression.", 0);
603
 
}
604
 
 
605
 
/*
606
 
struct bind_temp {
607
 
        object  bt_var;
608
 
        object  bt_spp;
609
 
        object  bt_init;
610
 
        object  bt_aux;
611
 
};
612
 
*/
613
 
 
614
 
object
615
 
find_special(object body, struct bind_temp *start, struct bind_temp *end)
616
 
{ 
617
 
        object temporary;
618
 
        object form=Cnil;
619
 
        object ds, vs, v;
620
 
        struct bind_temp *bt;
621
 
        bool special_processed;
622
 
        vs_mark;
623
 
 
624
 
        vs_push(Cnil);
625
 
        for (;  !endp(body);  body = body->c.c_cdr) {
626
 
                form = body->c.c_car;
627
 
 
628
 
                /*  MACRO EXPANSION  */
629
 
                form = macro_expand(form);
630
 
                vs_head = form;
631
 
 
632
 
                if (type_of(form) == t_string) {
633
 
                        if (endp(body->c.c_cdr))
634
 
                                break;
635
 
                        continue;
636
 
                }
637
 
                if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
638
 
                        break;
639
 
                for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
640
 
                        if (type_of(ds->c.c_car) != t_cons)
641
 
                                illegal_declare(form);
642
 
                        if (ds->c.c_car->c.c_car == sLspecial) {
643
 
                                vs = ds->c.c_car->c.c_cdr;
644
 
                                for (;  !endp(vs);  vs = vs->c.c_cdr) {
645
 
                                        v = vs->c.c_car;
646
 
                                        check_symbol(v);
647
 
/**/
648
 
        special_processed = FALSE;
649
 
        for (bt = start;  bt < end;  bt++)
650
 
                if (bt->bt_var == v) {
651
 
                        bt->bt_spp = Ct;
652
 
                        special_processed = TRUE;
653
 
                }
654
 
        if (special_processed)
655
 
                continue;
656
 
        /*  lex_special_bind(v);  */
657
 
        temporary = MMcons(v, Cnil);
658
 
        lex_env[0] = MMcons(temporary, lex_env[0]);
659
 
/**/
660
 
                                }
661
 
                        }
662
 
                }
663
 
        }
664
 
 
665
 
        if (body != Cnil && body->c.c_car != form)
666
 
                body = make_cons(form, body->c.c_cdr);
667
 
        vs_reset;
668
 
        return(body);
669
 
}
670
 
 
671
 
object
672
 
let_bind(object body, struct bind_temp *start, struct bind_temp *end)
673
 
{
674
 
        struct bind_temp *bt;
675
 
 
676
 
        bds_check;
677
 
        vs_push(find_special(body, start, end));
678
 
        for (bt = start;  bt < end;  bt++) {
679
 
                eval_assign(bt->bt_init, bt->bt_init);
680
 
        }
681
 
        for (bt = start;  bt < end;  bt++) {
682
 
                bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
683
 
        }
684
 
        return(vs_pop);
685
 
}
686
 
 
687
 
object
688
 
letA_bind(object body, struct bind_temp *start, struct bind_temp *end)
689
 
{
690
 
        struct bind_temp *bt;
691
 
        
692
 
        bds_check;
693
 
        vs_push(find_special(body, start, end));
694
 
        for (bt = start;  bt < end;  bt++) {
695
 
                eval_assign(bt->bt_init, bt->bt_init);
696
 
                bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
697
 
        }
698
 
        return(vs_pop);
699
 
}
700
 
 
701
 
 
702
 
#ifdef MV
703
 
 
704
 
#endif
705
 
 
706
 
#define NOT_YET         10
707
 
#define FOUND           11
708
 
#define NOT_KEYWORD     1
709
 
 
710
 
void
711
 
parse_key(object *base, bool rest, bool allow_other_keys,int n, ...)
712
 
{ 
713
 
        object temporary;
714
 
        va_list ap;
715
 
        object other_key = OBJNULL;
716
 
        int narg, error_flag = 0, allow_other_keys_found=0;
717
 
        object *v, k, *top;
718
 
        register int i;
719
 
 
720
 
        narg = vs_top - base;
721
 
        if (narg <= 0) {
722
 
                if (rest) {
723
 
                        base[0] = Cnil;
724
 
                        base++;
725
 
                }
726
 
                top = base + n;
727
 
                for (i = 0;  i < n;  i++) {
728
 
                        base[i] = Cnil;
729
 
                        top[i] = Cnil;
730
 
                }
731
 
                return;
732
 
        }
733
 
        if (narg%2 != 0)
734
 
          /* FIXME better message */
735
 
          FEunexpected_keyword(Cnil);
736
 
        if (narg == 2) {
737
 
                k = base[0];
738
 
                if (!keywordp(k))
739
 
                  FEunexpected_keyword(k);
740
 
                if (k == sKallow_other_keys && ! allow_other_keys_found) {
741
 
                  allow_other_keys_found=1;
742
 
                  if (base[1]!=Cnil)
743
 
                    allow_other_keys=TRUE;
744
 
                }
745
 
                temporary = base[1];
746
 
                if (rest)
747
 
                        base++;
748
 
                top = base + n;
749
 
                other_key = k == sKallow_other_keys ? OBJNULL : k;
750
 
                va_start(ap,n);
751
 
                for (i = 0;  i < n;  i++) {
752
 
                    
753
 
                        if (va_arg(ap,object) == k) {
754
 
                                base[i] = temporary;
755
 
                                top[i] = Ct;
756
 
                                other_key = OBJNULL;
757
 
                        } else {
758
 
                                base[i] = Cnil;
759
 
                                top[i] = Cnil;
760
 
                        }
761
 
                }
762
 
                va_end(ap);
763
 
                if (rest) {
764
 
                        temporary = make_cons(temporary, Cnil);
765
 
                        base[-1] = make_cons(k, temporary);
766
 
                }
767
 
                if (other_key != OBJNULL && !allow_other_keys)
768
 
                        FEunexpected_keyword(other_key);
769
 
                return;
770
 
        }
771
 
        va_start(ap,n);
772
 
        for (i = 0;  i < n;  i++) {
773
 
                k = va_arg(ap,object);
774
 
                k->s.s_stype = NOT_YET;
775
 
                k->s.s_dbind = Cnil;
776
 
        }
777
 
        va_end(ap);
778
 
        for (v = base;  v < vs_top;  v += 2) {
779
 
                k = v[0];
780
 
                if (!keywordp(k)) {
781
 
                        error_flag = NOT_KEYWORD;
782
 
                        other_key = k;
783
 
                        continue;
784
 
                }
785
 
                if (k->s.s_stype == NOT_YET) {
786
 
                        k->s.s_dbind = v[1];
787
 
                        k->s.s_stype = FOUND;
788
 
                } else if (k->s.s_stype == FOUND) {
789
 
                        ;
790
 
                } else if (other_key == OBJNULL && k!=sKallow_other_keys)
791
 
                        other_key = k;
792
 
                if (k == sKallow_other_keys && !allow_other_keys_found) {
793
 
                  allow_other_keys_found=1;
794
 
                  if (v[1] != Cnil)
795
 
                    allow_other_keys = TRUE;
796
 
                }
797
 
        }
798
 
        if (rest) {
799
 
                top = vs_top;
800
 
                vs_push(Cnil);
801
 
                base++;
802
 
                while (base < vs_top)
803
 
                        stack_cons();
804
 
                vs_top = top;
805
 
        }
806
 
        top = base + n;
807
 
        va_start(ap,n);
808
 
        for (i = 0;  i < n;  i++) {
809
 
                k = va_arg(ap,object);
810
 
                base[i] = k->s.s_dbind;
811
 
                top[i] = k->s.s_stype == FOUND ? Ct : Cnil;
812
 
                k->s.s_dbind = k;
813
 
                k->s.s_stype = (short)stp_constant;
814
 
        }
815
 
        va_end(ap);
816
 
        if (error_flag == NOT_KEYWORD)
817
 
          FEunexpected_keyword(other_key);
818
 
        if (other_key != OBJNULL && !allow_other_keys)
819
 
          FEunexpected_keyword(other_key);
820
 
}
821
 
 
822
 
void
823
 
check_other_key(object l, int n, ...)
824
 
{
825
 
        va_list ap;
826
 
        object other_key = OBJNULL;
827
 
        object k;
828
 
        int i;
829
 
        bool allow_other_keys = FALSE;
830
 
 
831
 
        for (;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
832
 
                k = l->c.c_car;
833
 
                if (!keywordp(k))
834
 
                  FEunexpected_keyword(k);
835
 
                if (endp(l->c.c_cdr))
836
 
                  /* FIXME better message */
837
 
                  FEunexpected_keyword(Cnil);
838
 
                if (k == sKallow_other_keys && l->c.c_cdr->c.c_car != Cnil) {
839
 
                        allow_other_keys = TRUE;
840
 
                } else {
841
 
                  char buf [100];
842
 
                  bzero(buf,n);
843
 
                  va_start(ap,n);
844
 
                  for (i = 0;  i < n;  i++)
845
 
                    { if (va_arg(ap,object) == k &&
846
 
                          buf[i] ==0) {buf[i]=1; break;}}
847
 
                  va_end(ap);
848
 
                  if (i >= n) other_key = k;
849
 
                }
850
 
        }
851
 
        if (other_key != OBJNULL && !allow_other_keys)
852
 
          FEunexpected_keyword(other_key);
853
 
}
854
 
 
855
 
 
856
 
/*  struct key {short n,allow_other_keys; */
857
 
/*          iobject *defaults; */
858
 
/*          iobject keys[1]; */
859
 
/*         }; */
860
 
 
861
 
 
862
 
object Cstd_key_defaults[15]={Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,
863
 
                                Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil};
864
 
 
865
 
/* FIXME rewrite this */
866
 
/* static int */
867
 
/* parse_key_new(int n, object *base, struct key *keys, va_list ap) */
868
 
/* {object *new; */
869
 
/*  COERCE_VA_LIST(new,ap,n); */
870
 
 
871
 
/*  new = new + n ; */
872
 
/*   {int j=keys->n; */
873
 
/*    object *p= (object *)(keys->defaults); */
874
 
/*    while (--j >=0) base[j]=p[j]; */
875
 
/*  } */
876
 
/*  {if (n==0){ return 0;} */
877
 
/*  {int allow = keys->allow_other_keys; */
878
 
/*   object k; */
879
 
 
880
 
/*   if (!allow) { */
881
 
/*     int i; */
882
 
/*     for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); */
883
 
/*     if (i>0 && new[-i+1]!=Cnil) */
884
 
/*       allow=1; */
885
 
/*   } */
886
 
 
887
 
/*  top: */
888
 
/*   while (n>=2) */
889
 
/*     {int i= keys->n; */
890
 
/*      iobject *ke=keys->keys ; */
891
 
/*      new = new -2; */
892
 
/*      k = *new; */
893
 
/*      while(--i >= 0) */
894
 
/*        {if ((*(ke++)).o == k) */
895
 
/*        {base[i]= new[1]; */
896
 
/*         n=n-2; */
897
 
/*         goto top; */
898
 
/*       }} */
899
 
     /* the key is a new one */
900
 
/*      if (allow || k==sKallow_other_keys)  */
901
 
/*        n=n-2; */
902
 
/*      else */
903
 
/*        goto error; */
904
 
/*    } */
905
 
  /* FIXME better message */
906
 
/*   if (n!=0) FEunexpected_keyword(Cnil); */
907
 
/*   return 0; */
908
 
/*  error: */
909
 
/*   FEunexpected_keyword(k); */
910
 
/*   return -1; */
911
 
/* }}} */
912
 
 
913
 
int
914
 
parse_key_new_new(int n, object *base, struct key *keys, object first, va_list ap)
915
 
{object *new;
916
 
 COERCE_VA_LIST_NEW(new,first,ap,n);
917
 
 
918
 
 /* from here down identical to parse_key_rest */
919
 
 new = new + n ;
920
 
  {int j=keys->n;
921
 
   object *p= (object *)(keys->defaults);
922
 
   while (--j >=0) base[j]=p[j];
923
 
 }
924
 
 {if (n==0){ return 0;}
925
 
 {int allow = keys->allow_other_keys;
926
 
  object k;
927
 
 
928
 
  if (!allow) {
929
 
    int i;
930
 
    for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2);
931
 
    if (i>0 && new[-i+1]!=Cnil)
932
 
      allow=1;
933
 
  }
934
 
 
935
 
 top:
936
 
  while (n>=2)
937
 
    {int i= keys->n;
938
 
     iobject *ke=keys->keys ;
939
 
     new = new -2;
940
 
     k = *new;
941
 
     while(--i >= 0)
942
 
       {if ((*(ke++)).o == k)
943
 
          {base[i]= new[1];
944
 
           n=n-2;
945
 
           goto top;
946
 
         }}
947
 
     /* the key is a new one */
948
 
     if (allow || k==sKallow_other_keys) 
949
 
       n=n-2;
950
 
     else
951
 
       goto error;
952
 
   }
953
 
  /* FIXME better message */
954
 
  if (n!=0) FEunexpected_keyword(Cnil);
955
 
  return 0;
956
 
 error:
957
 
  FEunexpected_keyword(k);
958
 
  return -1;
959
 
}}}
960
 
 
961
 
/* static int */
962
 
/* parse_key_rest(object rest, int n, object *base, struct key *keys, va_list ap) */
963
 
/* {object *new; */
964
 
/*  COERCE_VA_LIST(new,ap,n); */
965
 
 
966
 
 /* copy the rest arg */
967
 
/*  {object *p = new; */
968
 
/*   int m = n; */
969
 
/*   while (--m >= 0) */
970
 
/*     {rest->c.c_car = *p++; */
971
 
/*      rest = rest->c.c_cdr;}} */
972
 
    
973
 
/*  new = new + n ; */
974
 
/*   {int j=keys->n; */
975
 
/*    object *p= (object *)(keys->defaults); */
976
 
/*    while (--j >=0) base[j]=p[j]; */
977
 
/*  } */
978
 
/*  {if (n==0){ return 0;} */
979
 
/*  {int allow = keys->allow_other_keys; */
980
 
/*   object k; */
981
 
 
982
 
/*   if (!allow) { */
983
 
/*     int i; */
984
 
/*     for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2); */
985
 
/*     if (i>0 && new[-i+1]!=Cnil) */
986
 
/*       allow=1; */
987
 
/*   } */
988
 
 
989
 
/*  top: */
990
 
/*   while (n>=2) */
991
 
/*     {int i= keys->n; */
992
 
/*      iobject *ke=keys->keys ; */
993
 
/*      new = new -2; */
994
 
/*      k = *new; */
995
 
/*      while(--i >= 0) */
996
 
/*        {if ((*(ke++)).o == k) */
997
 
/*        {base[i]= new[1]; */
998
 
/*         n=n-2; */
999
 
/*         goto top; */
1000
 
/*       }} */
1001
 
     /* the key is a new one */
1002
 
/*      if (allow || k==sKallow_other_keys)  */
1003
 
/*        n=n-2; */
1004
 
/*      else */
1005
 
/*        goto error; */
1006
 
/*    } */
1007
 
  /* FIXME better message */
1008
 
/*   if (n!=0) FEunexpected_keyword(Cnil); */
1009
 
/*   return 0; */
1010
 
/*  error: */
1011
 
/*   FEunexpected_keyword(k); */
1012
 
/*   return -1; */
1013
 
/* }}} */
1014
 
 
1015
 
int
1016
 
parse_key_rest_new(object rest, int n, object *base, struct key *keys, object first,va_list ap)
1017
 
{object *new;
1018
 
 COERCE_VA_LIST_NEW(new,first,ap,n);
1019
 
 
1020
 
 /* copy the rest arg */
1021
 
 {object *p = new;
1022
 
  int m = n;
1023
 
  while (--m >= 0)
1024
 
    {rest->c.c_car = *p++;
1025
 
     rest = rest->c.c_cdr;}}
1026
 
    
1027
 
 new = new + n ;
1028
 
  {int j=keys->n;
1029
 
   object *p= (object *)(keys->defaults);
1030
 
   while (--j >=0) base[j]=p[j];
1031
 
 }
1032
 
 {if (n==0){ return 0;}
1033
 
 {int allow = keys->allow_other_keys;
1034
 
  object k;
1035
 
 
1036
 
  if (!allow) {
1037
 
    int i;
1038
 
    for (i=n;i>0 && new[-i]!=sKallow_other_keys;i-=2);
1039
 
    if (i>0 && new[-i+1]!=Cnil)
1040
 
      allow=1;
1041
 
  }
1042
 
 
1043
 
 top:
1044
 
  while (n>=2)
1045
 
    {int i= keys->n;
1046
 
     iobject *ke=keys->keys ;
1047
 
     new = new -2;
1048
 
     k = *new;
1049
 
     while(--i >= 0)
1050
 
       {if ((*(ke++)).o == k)
1051
 
          {base[i]= new[1];
1052
 
           n=n-2;
1053
 
           goto top;
1054
 
         }}
1055
 
     /* the key is a new one */
1056
 
     if (allow || k==sKallow_other_keys) 
1057
 
       n=n-2;
1058
 
     else
1059
 
       goto error;
1060
 
   }
1061
 
  /* FIXME better message */
1062
 
  if (n!=0) FEunexpected_keyword(Cnil);
1063
 
  return 0;
1064
 
 error:
1065
 
  FEunexpected_keyword(k);
1066
 
  return -1;
1067
 
}}}
1068
 
 
1069
 
  
1070
 
void
1071
 
set_key_struct(struct key *ks, object data)
1072
 
{int i=ks->n;
1073
 
 while (--i >=0)
1074
 
   {ks->keys[i].o =   data->cfd.cfd_self[ ks->keys[i].i ];
1075
 
    if (ks->defaults != (void *)Cstd_key_defaults)
1076
 
      {fixnum m=ks->defaults[i].i;
1077
 
        ks->defaults[i].o=
1078
 
          (m==-2 ? Cnil :
1079
 
           m==-1 ? (object)0 :
1080
 
           data->cfd.cfd_self[m]);}
1081
 
}}
1082
 
 
1083
 
#undef AUX
1084
 
 
1085
 
DEF_ORDINARY("ALLOW-OTHER-KEYS",sKallow_other_keys,KEYWORD,"");
1086
 
 
1087
 
 
1088
 
void
1089
 
gcl_init_bind(void)
1090
 
{
1091
 
        ANDoptional = make_ordinary("&OPTIONAL");
1092
 
        enter_mark_origin(&ANDoptional);
1093
 
        ANDrest = make_ordinary("&REST");
1094
 
        enter_mark_origin(&ANDrest);
1095
 
        ANDkey = make_ordinary("&KEY");
1096
 
        enter_mark_origin(&ANDkey);
1097
 
        ANDallow_other_keys = make_ordinary("&ALLOW-OTHER-KEYS");
1098
 
        enter_mark_origin(&ANDallow_other_keys);
1099
 
        ANDaux = make_ordinary("&AUX");
1100
 
        enter_mark_origin(&ANDaux);
1101
 
 
1102
 
        make_constant("LAMBDA-LIST-KEYWORDS",
1103
 
        make_cons(ANDoptional,
1104
 
        make_cons(ANDrest,
1105
 
        make_cons(ANDkey,
1106
 
        make_cons(ANDallow_other_keys,
1107
 
        make_cons(ANDaux,
1108
 
        make_cons(make_ordinary("&WHOLE"),
1109
 
        make_cons(make_ordinary("&ENVIRONMENT"),
1110
 
        make_cons(make_ordinary("&BODY"), Cnil)))))))));
1111
 
 
1112
 
        make_constant("LAMBDA-PARAMETERS-LIMIT",
1113
 
                      make_fixnum(64));
1114
 
 
1115
 
 
1116
 
 
1117
 
        three_nils.nil3_self[0] = Cnil;
1118
 
        three_nils.nil3_self[1] = Cnil;
1119
 
        three_nils.nil3_self[2] = Cnil;
1120
 
 
1121
 
        six_nils.nil6_self[0] = Cnil;
1122
 
        six_nils.nil6_self[1] = Cnil;
1123
 
        six_nils.nil6_self[2] = Cnil;
1124
 
        six_nils.nil6_self[3] = Cnil;
1125
 
        six_nils.nil6_self[4] = Cnil;
1126
 
        six_nils.nil6_self[5] = Cnil;
1127
 
}