← Back to branch summary

~ubuntu-branches/ubuntu/gutsy/vnc4/gutsy

« back to all changes in this revision

Viewing changes to unix/xc/programs/xedit/lisp/compile.c

  • Committer: Bazaar Package Importer
  • Author(s): Ola Lundqvist
  • Date: 2006-05-15 20:35:17 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20060515203517-l4lre1ku942mn26k
Tags: 4.1.1+X4.3.0-10
* Correction of critical security issue. Thanks to Martin Kogler
  <e9925248@student.tuwien.ac.at> that informed me about the issue,
  and provided the patch.
  This flaw was originally found by Steve Wiseman of intelliadmin.com.
* Applied patch from Javier Kohen <jkohen@users.sourceforge.net> that
  inform the user that only 8 first characters of the password will
  actually be used when typing more than 8 characters, closes:
  #355619.

Show diffs side-by-side

added added

removed removed

Lines of Context:
unix/xc/programs/xedit/lisp/compile.c
 
1
/*
 
2
 * Copyright (c) 2002 by The XFree86 Project, Inc.
 
3
 *
 
4
 * Permission is hereby granted, free of charge, to any person obtaining a
 
5
 * copy of this software and associated documentation files (the "Software"),
 
6
 * to deal in the Software without restriction, including without limitation
 
7
 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
 
8
 * and/or sell copies of the Software, and to permit persons to whom the
 
9
 * Software is furnished to do so, subject to the following conditions:
 
10
 *
 
11
 * The above copyright notice and this permission notice shall be included in
 
12
 * all copies or substantial portions of the Software.
 
13
 *
 
14
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 
15
 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 
16
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
 
17
 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 
18
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
 
19
 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 
20
 * SOFTWARE.
 
21
 *
 
22
 * Except as contained in this notice, the name of the XFree86 Project shall
 
23
 * not be used in advertising or otherwise to promote the sale, use or other
 
24
 * dealings in this Software without prior written authorization from the
 
25
 * XFree86 Project.
 
26
 *
 
27
 * Author: Paulo C�sar Pereira de Andrade
 
28
 */
 
29
 
 
30
/* $XFree86: xc/programs/xedit/lisp/compile.c,v 1.14 2003/01/30 02:46:25 paulo Exp $ */
 
31
 
 
32
#define VARIABLE_USED           0x0001
 
33
#define VARIABLE_ARGUMENT       0x0002
 
34
 
 
35
/*
 
36
 * Prototypes
 
37
 */
 
38
static void ComPredicate(LispCom*, LispBuiltin*, LispBytePredicate);
 
39
static void ComReturnFrom(LispCom*, LispBuiltin*, int);
 
40
 
 
41
static int ComConstantp(LispCom*, LispObj*);
 
42
static void ComAddVariable(LispCom*, LispObj*, LispObj*);
 
43
static int ComGetVariable(LispCom*, LispObj*);
 
44
static void ComVariableSetFlag(LispCom*, LispAtom*, int);
 
45
#define COM_VARIABLE_USED(atom)                         \
 
46
    ComVariableSetFlag(com, atom, VARIABLE_USED)
 
47
#define COM_VARIABLE_ARGUMENT(atom)                     \
 
48
        ComVariableSetFlag(com, atom, VARIABLE_ARGUMENT)
 
49
 
 
50
static int FindIndex(void*, void**, int);
 
51
static int compare(const void*, const void*);
 
52
static int BuildTablePointer(void*, void***, int*);
 
53
 
 
54
static void ComLabel(LispCom*, LispObj*);
 
55
static void ComPush(LispCom*, LispObj*, LispObj*, int, int, int);
 
56
static int ComCall(LispCom*, LispArgList*, LispObj*, LispObj*, int, int, int);
 
57
static void ComFuncall(LispCom*, LispObj*, LispObj*, int);
 
58
static void ComProgn(LispCom*, LispObj*);
 
59
static void ComEval(LispCom*, LispObj*);
 
60
 
 
61
static void ComRecursiveCall(LispCom*, LispArgList*, LispObj*, LispObj*);
 
62
static void ComInlineCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*);
 
63
 
 
64
static void ComMacroBackquote(LispCom*, LispObj*);
 
65
static void ComMacroCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*);
 
66
static LispObj *ComMacroExpandBackquote(LispCom*, LispObj*);
 
67
static LispObj *ComMacroExpand(LispCom*, LispObj*);
 
68
static LispObj *ComMacroExpandFuncall(LispCom*, LispObj*, LispObj*);
 
69
static LispObj *ComMacroExpandEval(LispCom*, LispObj*);
 
70
 
 
71
/*
 
72
 * Implementation
 
73
 */
 
74
void
 
75
Com_And(LispCom *com, LispBuiltin *builtin)
 
76
/*
 
77
 and &rest args
 
78
 */
 
79
{
 
80
    LispObj *args;
 
81
 
 
82
    args = ARGUMENT(0);
 
83
 
 
84
    if (CONSP(args)) {
 
85
        /* Evaluate first argument */
 
86
        ComEval(com, CAR(args));
 
87
        args = CDR(args);
 
88
 
 
89
        /* If more than one argument, create jump list */
 
90
        if (CONSP(args)) {
 
91
            CodeTree *tree = NULL, *group;
 
92
 
 
93
            group = NEW_TREE(CodeTreeJumpIf);
 
94
            group->code = XBC_JUMPNIL;
 
95
 
 
96
            for (; CONSP(args); args = CDR(args)) {
 
97
                ComEval(com, CAR(args));
 
98
                tree = NEW_TREE(CodeTreeJumpIf);
 
99
                tree->code = XBC_JUMPNIL;
 
100
                group->group = tree;
 
101
                group = tree;
 
102
            }
 
103
            /*  Finish form the last CodeTree code is changed to sign the
 
104
             * end of the AND list */
 
105
            group->code = XBC_NOOP;
 
106
            if (group)
 
107
                group->group = tree;
 
108
        }
 
109
    }
 
110
    else
 
111
        /* Identity of AND is T */
 
112
        com_Bytecode(com, XBC_T);
 
113
}
 
114
 
 
115
void
 
116
Com_Block(LispCom *com, LispBuiltin *builtin)
 
117
/*
 
118
 block name &rest body
 
119
 */
 
120
{
 
121
 
 
122
    LispObj *name, *body;
 
123
 
 
124
    body = ARGUMENT(1);
 
125
    name = ARGUMENT(0);
 
126
 
 
127
    if (name != NIL && name != T && !SYMBOLP(name))
 
128
        LispDestroy("%s: %s cannot name a block",
 
129
                    STRFUN(builtin), STROBJ(name));
 
130
    if (CONSP(body)) {
 
131
        CompileIniBlock(com, LispBlockTag, name);
 
132
        ComProgn(com, body);
 
133
        CompileFiniBlock(com);
 
134
    }
 
135
    else
 
136
        /* Just load NIL without starting an empty block */
 
137
        com_Bytecode(com, XBC_NIL);
 
138
}
 
139
 
 
140
void
 
141
Com_C_r(LispCom *com, LispBuiltin *builtin)
 
142
/*
 
143
 c[ad]{1,4}r list
 
144
 */
 
145
{
 
146
    LispObj *list;
 
147
    char *desc;
 
148
 
 
149
    list = ARGUMENT(0);
 
150
 
 
151
    desc = STRFUN(builtin);
 
152
    if (*desc == 'F')           /* FIRST */
 
153
        desc = "CAR";
 
154
    else if (*desc == 'R')      /* REST */
 
155
        desc = "CDR";
 
156
 
 
157
    /* Check if it is a list of constants */
 
158
    while (desc[1] != 'R')
 
159
        desc++;
 
160
    ComEval(com, list);
 
161
    while (*desc != 'C') {
 
162
        com_Bytecode(com, *desc == 'A' ? XBC_CAR : XBC_CDR);
 
163
        --desc;
 
164
    }
 
165
}
 
166
 
 
167
void
 
168
Com_Cond(LispCom *com, LispBuiltin *builtin)
 
169
/*
 
170
 cond &rest body
 
171
 */
 
172
{
 
173
    int count;
 
174
    LispObj *code, *body;
 
175
    CodeTree *group, *tree;
 
176
 
 
177
    body = ARGUMENT(0);
 
178
 
 
179
    count = 0;
 
180
    group = NULL;
 
181
    if (CONSP(body)) {
 
182
        for (; CONSP(body); body = CDR(body)) {
 
183
            code = CAR(body);
 
184
            CHECK_CONS(code);
 
185
            ++count;
 
186
            ComEval(com, CAR(code));
 
187
            tree = NEW_TREE(CodeTreeCond);
 
188
            if (group)
 
189
                group->group = tree;
 
190
            tree->code = XBC_JUMPNIL;
 
191
            group = tree;
 
192
            /* The code to execute if the test is true */
 
193
            ComProgn(com, CDR(code));
 
194
            /* Add a node signaling the end of the PROGN code */
 
195
            tree = NEW_TREE(CodeTreeCond);
 
196
            tree->code = XBC_JUMPT;
 
197
            if (group)
 
198
                group->group = tree;
 
199
            group = tree;
 
200
        }
 
201
    }
 
202
    if (!count)
 
203
        com_Bytecode(com, XBC_NIL);
 
204
    else
 
205
        /* Where to jump after T progn */
 
206
        group->code = XBC_NOOP;
 
207
}
 
208
 
 
209
void
 
210
Com_Cons(LispCom *com, LispBuiltin *builtin)
 
211
/*
 
212
 cons car cdr
 
213
 */
 
214
{
 
215
    LispObj *car, *cdr;
 
216
 
 
217
    cdr = ARGUMENT(1);
 
218
    car = ARGUMENT(0);
 
219
 
 
220
    if (ComConstantp(com, car) && ComConstantp(com, cdr))
 
221
        com_BytecodeCons(com, XBC_CCONS, car, cdr);
 
222
    else {
 
223
        ++com->stack.cpstack;
 
224
        if (com->stack.pstack < com->stack.cpstack)
 
225
            com->stack.pstack = com->stack.cpstack;
 
226
        ComEval(com, car);
 
227
        com_Bytecode(com, XBC_CSTAR);
 
228
        ComEval(com, cdr);
 
229
        com_Bytecode(com, XBC_CFINI);
 
230
        --com->stack.cpstack;
 
231
    }
 
232
}
 
233
 
 
234
void
 
235
Com_Consp(LispCom *com, LispBuiltin *builtin)
 
236
/*
 
237
 consp object
 
238
 */
 
239
{
 
240
    ComPredicate(com, builtin, XBP_CONSP);
 
241
}
 
242
 
 
243
void
 
244
Com_Dolist(LispCom *com, LispBuiltin *builtin)
 
245
/*
 
246
 dolist init &rest body
 
247
 */
 
248
{
 
249
    int unbound, item;
 
250
    LispObj *symbol, *list, *result;
 
251
    LispObj *init, *body;
 
252
    CodeTree *group, *tree;
 
253
 
 
254
    body = ARGUMENT(1);
 
255
    init = ARGUMENT(0);
 
256
 
 
257
    CHECK_CONS(init);
 
258
    symbol = CAR(init);
 
259
    CHECK_SYMBOL(symbol);
 
260
    CHECK_CONSTANT(symbol);
 
261
    init = CDR(init);
 
262
    if (CONSP(init)) {
 
263
        list = CAR(init);
 
264
        init = CDR(init);
 
265
    }
 
266
    else
 
267
        list = NIL;
 
268
    if (CONSP(init)) {
 
269
        result = CAR(init);
 
270
        if (CONSP(CDR(init)))
 
271
            LispDestroy("%s: too many arguments %s",
 
272
                        STRFUN(builtin), STROBJ(CDR(init)));
 
273
    }
 
274
    else
 
275
        result = NIL;
 
276
 
 
277
    /*  Generate code for the body of the form.
 
278
     *  The generated code uses two objects unavailable to user code,
 
279
     * in the format:
 
280
     *  (block NIL
 
281
     *      (let ((? list) (item NIL))
 
282
     *          (tagbody
 
283
     *              .                       ; the DOT object as a label
 
284
     *              (when (consp list)
 
285
     *                  (setq item (car ?))
 
286
     *                  @body               ; code to be executed
 
287
     *                  (setq ? (cdr ?))
 
288
     *                  (go .)
 
289
     *              )
 
290
     *          )
 
291
     *          (setq item nil)
 
292
     *          result
 
293
     *      )
 
294
     *  )
 
295
     */
 
296
 
 
297
    /* XXX All of the logic below should be simplified at some time
 
298
     * by adding more opcodes for compound operations ... */
 
299
 
 
300
    /* Relative offsets the locally added variables will have at run time */
 
301
    unbound = lisp__data.env.length - lisp__data.env.lex;
 
302
    item = unbound + 1;
 
303
 
 
304
    /* Start BLOCK NIL */
 
305
    FORM_ENTER();
 
306
    CompileIniBlock(com, LispBlockTag, NIL);
 
307
 
 
308
    /* Add the <?> variable */
 
309
    ComPush(com, UNBOUND, list, 1, 0, 0);
 
310
    /* Add the <item> variable */
 
311
    ComPush(com, symbol, NIL, 0, 0, 0);
 
312
    /* Stack length is increased */
 
313
    CompileStackEnter(com, 2, 0);
 
314
    /* Bind variables */
 
315
    com_Bind(com, 2);
 
316
    com->block->bind += 2;
 
317
    lisp__data.env.head += 2;
 
318
 
 
319
    /* Remember that iteration variable is used even if it not referenced */
 
320
    COM_VARIABLE_USED(symbol->data.atom);
 
321
 
 
322
    /* Initialize the TAGBODY */
 
323
    FORM_ENTER();
 
324
    CompileIniBlock(com, LispBlockBody, NIL);
 
325
 
 
326
    /* Create the <.> label */
 
327
    ComLabel(com, DOT);
 
328
 
 
329
    /* Load <?> variable */
 
330
    com_BytecodeShort(com, XBC_LOAD, unbound);
 
331
    /* Check if <?> is a list */
 
332
    com_BytecodeChar(com, XBC_PRED, XBP_CONSP);
 
333
 
 
334
    /* Start WHEN block */
 
335
    group = NEW_TREE(CodeTreeJumpIf);
 
336
    group->code = XBC_JUMPNIL;
 
337
    /* Load <?> again */
 
338
    com_BytecodeShort(com, XBC_LOAD, unbound);
 
339
    /* Get CAR of <?> */
 
340
    com_Bytecode(com, XBC_CAR);
 
341
    /* Store it in <item> */
 
342
    com_BytecodeShort(com, XBC_SET, item);
 
343
    /* Execute @BODY */
 
344
    ComProgn(com, body);
 
345
 
 
346
    /* Load <?> again */
 
347
    com_BytecodeShort(com, XBC_LOAD, unbound);
 
348
    /* Get CDR of <?> */
 
349
    com_Bytecode(com, XBC_CDR);
 
350
    /* Change value of <?> */
 
351
    com_BytecodeShort(com, XBC_SET, unbound);
 
352
 
 
353
    /* GO back to <.> */
 
354
    tree = NEW_TREE(CodeTreeGo);
 
355
    tree->data.object = DOT;
 
356
 
 
357
    /* Finish WHEN block */
 
358
    tree = NEW_TREE(CodeTreeJumpIf);
 
359
    tree->code = XBC_NOOP;
 
360
    group->group = tree;
 
361
 
 
362
    /* Finish the TAGBODY */
 
363
    CompileFiniBlock(com);
 
364
    FORM_LEAVE();
 
365
 
 
366
    /* Set <item> to NIL, in case result references it...
 
367
     * Loaded value is NIL as the CONSP predicate */
 
368
    com_BytecodeShort(com, XBC_SET, item);
 
369
 
 
370
    /* Evaluate <result> */
 
371
    ComEval(com, result);
 
372
 
 
373
    /* Unbind variables */
 
374
    lisp__data.env.head -= 2;
 
375
    lisp__data.env.length -= 2;
 
376
    com->block->bind -= 2;
 
377
    com_Unbind(com, 2);
 
378
    /* Stack length is reduced. */
 
379
    CompileStackLeave(com, 2, 0);
 
380
 
 
381
    /* Finish BLOCK NIL */
 
382
    CompileFiniBlock(com);
 
383
    FORM_LEAVE();
 
384
}
 
385
 
 
386
void
 
387
Com_Eq(LispCom *com, LispBuiltin *builtin)
 
388
/*
 
389
 eq left right
 
390
 eql left right
 
391
 equal left right
 
392
 equalp left right
 
393
 */
 
394
{
 
395
    LispObj *left, *right;
 
396
    LispByteOpcode code;
 
397
    char *name;
 
398
 
 
399
    right = ARGUMENT(1);
 
400
    left = ARGUMENT(0);
 
401
 
 
402
    CompileStackEnter(com, 1, 1);
 
403
    /* Just like preparing to call a builtin function */
 
404
    ComEval(com, left);
 
405
    com_Bytecode(com, XBC_PUSH);
 
406
    /* The second argument is now loaded */
 
407
    ComEval(com, right);
 
408
 
 
409
    /* Compare arguments and restore builtin stack */
 
410
    name = STRFUN(builtin);
 
411
    switch (name[3]) {
 
412
        case 'L':
 
413
            code = XBC_EQL;
 
414
            break;
 
415
        case 'U':
 
416
            code = name[5] == 'P' ? XBC_EQUALP : XBC_EQUAL;
 
417
            break;
 
418
        default:
 
419
            code = XBC_EQ;
 
420
            break;
 
421
    }
 
422
    com_Bytecode(com, code);
 
423
 
 
424
    CompileStackLeave(com, 1, 1);
 
425
}
 
426
 
 
427
void
 
428
Com_Go(LispCom *com, LispBuiltin *builtin)
 
429
/*
 
430
 go tag
 
431
 */
 
432
{
 
433
    int bind;
 
434
    LispObj *tag;
 
435
    CodeTree *tree;
 
436
    CodeBlock *block;
 
437
 
 
438
    tag = ARGUMENT(0);
 
439
 
 
440
    block = com->block;
 
441
    bind = block->bind;
 
442
 
 
443
    while (block) {
 
444
        if (block->type == LispBlockClosure || block->type == LispBlockBody)
 
445
            break;
 
446
        block = block->prev;
 
447
        if (block)
 
448
            bind += block->bind;
 
449
    }
 
450
 
 
451
    if (!block || block->type != LispBlockBody)
 
452
        LispDestroy("%s called not within a block", STRFUN(builtin));
 
453
 
 
454
    /* Unbind any local variables */
 
455
    com_Unbind(com, bind);
 
456
    tree = NEW_TREE(CodeTreeGo);
 
457
    tree->data.object = tag;
 
458
}
 
459
 
 
460
void
 
461
Com_If(LispCom *com, LispBuiltin *builtin)
 
462
/*
 
463
 if test then &optional else
 
464
 */
 
465
{
 
466
    CodeTree *group, *tree;
 
467
    LispObj *test, *then, *oelse;
 
468
 
 
469
    oelse = ARGUMENT(2);
 
470
    then = ARGUMENT(1);
 
471
    test = ARGUMENT(0);
 
472
 
 
473
    /* Build code to execute test */
 
474
    ComEval(com, test);
 
475
 
 
476
    /* Add jump node to use if test is NIL */
 
477
    group = NEW_TREE(CodeTreeJumpIf);
 
478
    group->code = XBC_JUMPNIL;
 
479
 
 
480
    /* Build T code */
 
481
    ComEval(com, then);
 
482
 
 
483
    if (oelse != UNSPEC) {
 
484
        /* Remember start of NIL code */
 
485
        tree = NEW_TREE(CodeTreeJump);
 
486
        tree->code = XBC_JUMP;
 
487
        group->group = tree;
 
488
        group = tree;
 
489
        /* Build NIL code */
 
490
        ComEval(com, oelse);
 
491
    }
 
492
 
 
493
    /* Remember jump of T code */
 
494
    tree = NEW_TREE(CodeTreeJumpIf);
 
495
    tree->code = XBC_NOOP;
 
496
    group->group = tree;
 
497
}
 
498
 
 
499
void
 
500
Com_Last(LispCom *com, LispBuiltin *builtin)
 
501
/*
 
502
 last list &optional count
 
503
 */
 
504
{
 
505
    LispObj *list, *count;
 
506
 
 
507
    count = ARGUMENT(1);
 
508
    list = ARGUMENT(0);
 
509
 
 
510
    ComEval(com, list);
 
511
    CompileStackEnter(com, 1, 1);
 
512
    com_Bytecode(com, XBC_PUSH);
 
513
    if (count == UNSPEC)
 
514
        count = FIXNUM(1);
 
515
    ComEval(com, count);
 
516
    CompileStackLeave(com, 1, 1);
 
517
    com_Bytecode(com, XBC_LAST);
 
518
}
 
519
 
 
520
void
 
521
Com_Length(LispCom *com, LispBuiltin *builtin)
 
522
/*
 
523
 length sequence
 
524
 */
 
525
{
 
526
    LispObj *sequence;
 
527
 
 
528
    sequence = ARGUMENT(0);
 
529
 
 
530
    ComEval(com, sequence);
 
531
    com_Bytecode(com, XBC_LENGTH);
 
532
}
 
533
 
 
534
void
 
535
Com_Let(LispCom *com, LispBuiltin *builtin)
 
536
/*
 
537
 let init &rest body
 
538
 */
 
539
{
 
540
    int count;
 
541
    LispObj *symbol, *value, *pair;
 
542
 
 
543
    LispObj *init, *body;
 
544
 
 
545
    body = ARGUMENT(1);
 
546
    init = ARGUMENT(0);
 
547
 
 
548
    if (init == NIL) {
 
549
        /* If no local variables */
 
550
        ComProgn(com, body);
 
551
        return;
 
552
    }
 
553
    CHECK_CONS(init);
 
554
 
 
555
    /* Could optimize if the body is empty and the
 
556
     * init form is known to have no side effects */
 
557
 
 
558
    for (count = 0; CONSP(init); init = CDR(init), count++) {
 
559
        pair = CAR(init);
 
560
        if (CONSP(pair)) {
 
561
            symbol = CAR(pair);
 
562
            pair = CDR(pair);
 
563
            if (CONSP(pair)) {
 
564
                value = CAR(pair);
 
565
                if (CDR(pair) != NIL)
 
566
                    LispDestroy("%s: too much arguments to initialize %s",
 
567
                                STRFUN(builtin), STROBJ(symbol));
 
568
            }
 
569
            else
 
570
                value = NIL;
 
571
        }
 
572
        else {
 
573
            symbol = pair;
 
574
            value = NIL;
 
575
        }
 
576
        CHECK_SYMBOL(symbol);
 
577
        CHECK_CONSTANT(symbol);
 
578
 
 
579
        /* Add the variable */
 
580
        ComPush(com, symbol, value, 1, 0, 0);
 
581
    }
 
582
 
 
583
    /* Stack length is increased */
 
584
    CompileStackEnter(com, count, 0);
 
585
    /* Bind the added variables */
 
586
    com_Bind(com, count);
 
587
    com->block->bind += count;
 
588
    lisp__data.env.head += count;
 
589
    /* Generate code for the body of the form */
 
590
    ComProgn(com, body);
 
591
    /* Unbind the added variables */
 
592
    lisp__data.env.head -= count;
 
593
    lisp__data.env.length -= count;
 
594
    com->block->bind -= count;
 
595
    com_Unbind(com, count);
 
596
    /* Stack length is reduced. */
 
597
    CompileStackLeave(com, count, 0);
 
598
}
 
599
 
 
600
void
 
601
Com_Letx(LispCom *com, LispBuiltin *builtin)
 
602
/*
 
603
 let* init &rest body
 
604
 */
 
605
{
 
606
    int count;
 
607
    LispObj *symbol, *value, *pair;
 
608
 
 
609
    LispObj *init, *body;
 
610
 
 
611
    body = ARGUMENT(1);
 
612
    init = ARGUMENT(0);
 
613
 
 
614
    if (init == NIL) {
 
615
        /* If no local variables */
 
616
        ComProgn(com, body);
 
617
        return;
 
618
    }
 
619
    CHECK_CONS(body);
 
620
 
 
621
    /* Could optimize if the body is empty and the
 
622
     * init form is known to have no side effects */
 
623
 
 
624
    for (count = 0; CONSP(init); init = CDR(init), count++) {
 
625
        pair = CAR(init);
 
626
        if (CONSP(pair)) {
 
627
            symbol = CAR(pair);
 
628
            pair = CDR(pair);
 
629
            if (CONSP(pair)) {
 
630
                value = CAR(pair);
 
631
                if (CDR(pair) != NIL)
 
632
                    LispDestroy("%s: too much arguments to initialize %s",
 
633
                                STRFUN(builtin), STROBJ(symbol));
 
634
            }
 
635
            else
 
636
                value = NIL;
 
637
        }
 
638
        else {
 
639
            symbol = pair;
 
640
            value = NIL;
 
641
        }
 
642
        CHECK_SYMBOL(symbol);
 
643
        CHECK_CONSTANT(symbol);
 
644
 
 
645
        /* LET* is identical to &AUX arguments, just bind the symbol */
 
646
        ComPush(com, symbol, value, 1, 0, 0);
 
647
        /* Every added variable is binded */
 
648
        com_Bind(com, 1);
 
649
        /* Must be binded at compile time also */
 
650
        ++lisp__data.env.head;
 
651
        ++com->block->bind;
 
652
    }
 
653
 
 
654
    /* Generate code for the body of the form */
 
655
    CompileStackEnter(com, count, 0);
 
656
    ComProgn(com, body);
 
657
    com_Unbind(com, count);
 
658
    com->block->bind -= count;
 
659
    lisp__data.env.head -= count;
 
660
    lisp__data.env.length -= count;
 
661
    CompileStackLeave(com, count, 0);
 
662
}
 
663
 
 
664
void
 
665
Com_Listp(LispCom *com, LispBuiltin *builtin)
 
666
/*
 
667
 listp object
 
668
 */
 
669
{
 
670
    ComPredicate(com, builtin, XBP_LISTP);
 
671
}
 
672
 
 
673
void
 
674
Com_Loop(LispCom *com, LispBuiltin *builtin)
 
675
/*
 
676
 loop &rest body
 
677
 */
 
678
{
 
679
    CodeTree *tree, *group;
 
680
    LispObj *body;
 
681
 
 
682
    body = ARGUMENT(0);
 
683
 
 
684
    /* Start NIL block */
 
685
    CompileIniBlock(com, LispBlockTag, NIL);
 
686
 
 
687
    /* Insert node to mark LOOP start */
 
688
    tree = NEW_TREE(CodeTreeJump);
 
689
    tree->code = XBC_NOOP;
 
690
 
 
691
    /* Execute @BODY */
 
692
    if (CONSP(body))
 
693
        ComProgn(com, body);
 
694
    else
 
695
        /* XXX bytecode.c code require that blocks have at least one opcode */
 
696
        com_Bytecode(com, XBC_NIL);
 
697
 
 
698
    /* Insert node to jump of start of LOOP */
 
699
    group = NEW_TREE(CodeTreeJump);
 
700
    group->code = XBC_JUMP;
 
701
    group->group = tree;
 
702
 
 
703
    /* Finish NIL block */
 
704
    CompileFiniBlock(com);
 
705
}
 
706
 
 
707
void
 
708
Com_Nthcdr(LispCom *com, LispBuiltin *builtin)
 
709
/*
 
710
 nthcdr index list
 
711
 */
 
712
{
 
713
    LispObj *oindex, *list;
 
714
 
 
715
    list = ARGUMENT(1);
 
716
    oindex = ARGUMENT(0);
 
717
 
 
718
    ComEval(com, oindex);
 
719
    CompileStackEnter(com, 1, 1);
 
720
    com_Bytecode(com, XBC_PUSH);
 
721
    ComEval(com, list);
 
722
    CompileStackLeave(com, 1, 1);
 
723
    com_Bytecode(com, XBC_NTHCDR);
 
724
}
 
725
 
 
726
void
 
727
Com_Null(LispCom *com, LispBuiltin *builtin)
 
728
/*
 
729
 null list
 
730
 */
 
731
{
 
732
    LispObj *list;
 
733
 
 
734
    list = ARGUMENT(0);
 
735
 
 
736
    if (list == NIL)
 
737
        com_Bytecode(com, XBC_T);
 
738
    else if (ComConstantp(com, list))
 
739
        com_Bytecode(com, XBC_NIL);
 
740
    else {
 
741
        ComEval(com, list);
 
742
        com_Bytecode(com, XBC_INV);
 
743
    }
 
744
}
 
745
 
 
746
void
 
747
Com_Numberp(LispCom *com, LispBuiltin *builtin)
 
748
/*
 
749
 numberp object
 
750
 */
 
751
{
 
752
    ComPredicate(com, builtin, XBP_NUMBERP);
 
753
}
 
754
 
 
755
void
 
756
Com_Or(LispCom *com, LispBuiltin *builtin)
 
757
/*
 
758
 or &rest args
 
759
 */
 
760
{
 
761
    LispObj *args;
 
762
 
 
763
    args = ARGUMENT(0);
 
764
 
 
765
    if (CONSP(args)) {
 
766
        /* Evaluate first argument */
 
767
        ComEval(com, CAR(args));
 
768
        args = CDR(args);
 
769
 
 
770
        /* If more than one argument, create jump list */
 
771
        if (CONSP(args)) {
 
772
            CodeTree *tree = NULL, *group;
 
773
 
 
774
            group = NEW_TREE(CodeTreeJumpIf);
 
775
            group->code = XBC_JUMPT;
 
776
 
 
777
            for (; CONSP(args); args = CDR(args)) {
 
778
                ComEval(com, CAR(args));
 
779
                tree = NEW_TREE(CodeTreeJumpIf);
 
780
                tree->code = XBC_JUMPT;
 
781
                group->group = tree;
 
782
                group = tree;
 
783
            }
 
784
            /*  Finish form the last CodeTree code is changed to sign the
 
785
             * end of the AND list */
 
786
            group->code = XBC_NOOP;
 
787
            group->group = tree;
 
788
        }
 
789
    }
 
790
    else
 
791
        /* Identity of OR is NIL */
 
792
        com_Bytecode(com, XBC_NIL);
 
793
}
 
794
 
 
795
void
 
796
Com_Progn(LispCom *com, LispBuiltin *builtin)
 
797
/*
 
798
 progn &rest body
 
799
 */
 
800
{
 
801
    LispObj *body;
 
802
 
 
803
    body = ARGUMENT(0);
 
804
 
 
805
    ComProgn(com, body);
 
806
}
 
807
 
 
808
void
 
809
Com_Return(LispCom *com, LispBuiltin *builtin)
 
810
/*
 
811
 return &optional result
 
812
 */
 
813
{
 
814
    ComReturnFrom(com, builtin, 0);
 
815
}
 
816
 
 
817
void
 
818
Com_ReturnFrom(LispCom *com, LispBuiltin *builtin)
 
819
/*
 
820
 return-from name &optional result
 
821
 */
 
822
{
 
823
    ComReturnFrom(com, builtin, 1);
 
824
}
 
825
 
 
826
void
 
827
Com_Rplac_(LispCom *com, LispBuiltin *builtin)
 
828
/*
 
829
 rplac[ad] place value
 
830
 */
 
831
{
 
832
    LispObj *place, *value;
 
833
 
 
834
    value = ARGUMENT(1);
 
835
    place = ARGUMENT(0);
 
836
 
 
837
    CompileStackEnter(com, 1, 1);
 
838
    ComEval(com, place);
 
839
    com_Bytecode(com, XBC_PUSH);
 
840
    ComEval(com, value);
 
841
    com_Bytecode(com, STRFUN(builtin)[5] == 'A' ? XBC_RPLACA : XBC_RPLACD);
 
842
    CompileStackLeave(com, 1, 1);
 
843
}
 
844
 
 
845
void
 
846
Com_Setq(LispCom *com, LispBuiltin *builtin)
 
847
/*
 
848
 setq &rest form
 
849
 */
 
850
{
 
851
    int offset;
 
852
    LispObj *form, *symbol, *value;
 
853
 
 
854
    form = ARGUMENT(0);
 
855
 
 
856
    for (; CONSP(form); form = CDR(form)) {
 
857
        symbol = CAR(form);
 
858
        CHECK_SYMBOL(symbol);
 
859
        CHECK_CONSTANT(symbol);
 
860
        form = CDR(form);
 
861
        if (!CONSP(form))
 
862
            LispDestroy("%s: odd number of arguments", STRFUN(builtin));
 
863
        value = CAR(form);
 
864
        /* Generate code to load value */
 
865
        ComEval(com, value);
 
866
        offset = ComGetVariable(com, symbol);
 
867
        if (offset >= 0)
 
868
            com_Set(com, offset);
 
869
        else
 
870
            com_SetSym(com, symbol->data.atom);
 
871
    }
 
872
}
 
873
 
 
874
void
 
875
Com_Tagbody(LispCom *com, LispBuiltin *builtin)
 
876
/*
 
877
 tagbody &rest body
 
878
 */
 
879
{
 
880
    LispObj *body;
 
881
 
 
882
    body = ARGUMENT(0);
 
883
 
 
884
    if (CONSP(body)) {
 
885
        CompileIniBlock(com, LispBlockBody, NIL);
 
886
        ComProgn(com, body);
 
887
        /* Tagbody returns NIL */
 
888
        com_Bytecode(com, XBC_NIL);
 
889
        CompileFiniBlock(com);
 
890
    }
 
891
    else
 
892
        /* Tagbody always returns NIL */
 
893
        com_Bytecode(com, XBC_NIL);
 
894
}
 
895
 
 
896
void
 
897
Com_Unless(LispCom *com, LispBuiltin *builtin)
 
898
/*
 
899
 unless test &rest body
 
900
 */
 
901
{
 
902
    CodeTree *group, *tree;
 
903
    LispObj *test, *body;
 
904
 
 
905
    body = ARGUMENT(1);
 
906
    test = ARGUMENT(0);
 
907
 
 
908
    /* Generate code to evaluate test */
 
909
    ComEval(com, test);
 
910
    /* Add node after test */
 
911
    group = NEW_TREE(CodeTreeJumpIf);
 
912
    group->code = XBC_JUMPT;
 
913
    /* Generate NIL code */
 
914
    ComProgn(com, body);
 
915
    /* Insert node to know where to jump if test is T */
 
916
    tree = NEW_TREE(CodeTreeJumpIf);
 
917
    tree->code = XBC_NOOP;
 
918
    group->group = tree;
 
919
}
 
920
 
 
921
void
 
922
Com_Until(LispCom *com, LispBuiltin *builtin)
 
923
/*
 
924
 until test &rest body
 
925
 */
 
926
{
 
927
    CodeTree *tree, *group, *ltree, *lgroup;
 
928
    LispObj *test, *body;
 
929
 
 
930
    body = ARGUMENT(1);
 
931
    test = ARGUMENT(0);
 
932
 
 
933
    /* Insert node to mark LOOP start */
 
934
    ltree = NEW_TREE(CodeTreeJump);
 
935
    ltree->code = XBC_NOOP;
 
936
 
 
937
    /* Build code for test */
 
938
    ComEval(com, test);
 
939
    group = NEW_TREE(CodeTreeJumpIf);
 
940
    group->code = XBC_JUMPT;
 
941
 
 
942
    /* Execute @BODY */
 
943
    ComProgn(com, body);
 
944
 
 
945
    /* Insert node to jump to test again */
 
946
    lgroup = NEW_TREE(CodeTreeJump);
 
947
    lgroup->code = XBC_JUMP;
 
948
    lgroup->group = ltree;
 
949
 
 
950
    /* Insert node to know where to jump if test is T */
 
951
    tree = NEW_TREE(CodeTreeJumpIf);
 
952
    tree->code = XBC_NOOP;
 
953
    group->group = tree;
 
954
}
 
955
 
 
956
void
 
957
Com_When(LispCom *com, LispBuiltin *builtin)
 
958
/*
 
959
 when test &rest body
 
960
 */
 
961
{
 
962
    CodeTree *group, *tree;
 
963
    LispObj *test, *body;
 
964
 
 
965
    body = ARGUMENT(1);
 
966
    test = ARGUMENT(0);
 
967
 
 
968
    /* Generate code to evaluate test */
 
969
    ComEval(com, test);
 
970
    /* Add node after test */
 
971
    group = NEW_TREE(CodeTreeJumpIf);
 
972
    group->code = XBC_JUMPNIL;
 
973
    /* Generate T code */
 
974
    ComProgn(com, body);
 
975
    /* Insert node to know where to jump if test is NIL */
 
976
    tree = NEW_TREE(CodeTreeJumpIf);
 
977
    tree->code = XBC_NOOP;
 
978
    group->group = tree;
 
979
}
 
980
 
 
981
void
 
982
Com_While(LispCom *com, LispBuiltin *builtin)
 
983
/*
 
984
 while test &rest body
 
985
 */
 
986
{
 
987
    CodeTree *tree, *group, *ltree, *lgroup;
 
988
    LispObj *test, *body;
 
989
 
 
990
    body = ARGUMENT(1);
 
991
    test = ARGUMENT(0);
 
992
 
 
993
    /* Insert node to mark LOOP start */
 
994
    ltree = NEW_TREE(CodeTreeJump);
 
995
    ltree->code = XBC_NOOP;
 
996
 
 
997
    /* Build code for test */
 
998
    ComEval(com, test);
 
999
    group = NEW_TREE(CodeTreeJumpIf);
 
1000
    group->code = XBC_JUMPNIL;
 
1001
 
 
1002
    /* Execute @BODY */
 
1003
    ComProgn(com, body);
 
1004
 
 
1005
    /* Insert node to jump to test again */
 
1006
    lgroup = NEW_TREE(CodeTreeJump);
 
1007
    lgroup->code = XBC_JUMP;
 
1008
    lgroup->group = ltree;
 
1009
 
 
1010
    /* Insert node to know where to jump if test is NIL */
 
1011
    tree = NEW_TREE(CodeTreeJumpIf);
 
1012
    tree->code = XBC_NOOP;
 
1013
    group->group = tree;
 
1014
}
 
1015
 
 
1016
 
 
1017
/***********************************************************************
 
1018
 * Com_XXX helper functions
 
1019
 ***********************************************************************/
 
1020
static void
 
1021
ComPredicate(LispCom *com, LispBuiltin *builtin, LispBytePredicate predicate)
 
1022
{
 
1023
    LispObj *object;
 
1024
 
 
1025
    object = ARGUMENT(0);
 
1026
 
 
1027
    if (ComConstantp(com, object)) {
 
1028
        switch (predicate) {
 
1029
            case XBP_CONSP:
 
1030
                com_Bytecode(com, CONSP(object) ? XBC_T : XBC_NIL);
 
1031
                break;
 
1032
            case XBP_LISTP:
 
1033
                com_Bytecode(com, CONSP(object) || object == NIL ?
 
1034
                             XBC_T : XBC_NIL);
 
1035
                break;
 
1036
            case XBP_NUMBERP:
 
1037
                com_Bytecode(com, NUMBERP(object) ? XBC_T : XBC_NIL);
 
1038
                break;
 
1039
        }
 
1040
    }
 
1041
    else {
 
1042
        ComEval(com, object);
 
1043
        com_BytecodeChar(com, XBC_PRED, predicate);
 
1044
    }
 
1045
}
 
1046
 
 
1047
/* XXX Could receive an argument telling if is the last statement in the
 
1048
 * block(s), i.e. if a jump opcode should be generated or just the
 
1049
 * evaluation of the returned value. Probably this is better done in
 
1050
 * an optimization step. */
 
1051
static void
 
1052
ComReturnFrom(LispCom *com, LispBuiltin *builtin, int from)
 
1053
{
 
1054
    int bind;
 
1055
    CodeTree *tree;
 
1056
    LispObj *name, *result;
 
1057
    CodeBlock *block = com->block;
 
1058
 
 
1059
    if (from) {
 
1060
        result = ARGUMENT(1);
 
1061
        name = ARGUMENT(0);
 
1062
    }
 
1063
    else {
 
1064
        result = ARGUMENT(0);
 
1065
        name = NIL;
 
1066
    }
 
1067
    if (result == UNSPEC)
 
1068
        result = NIL;
 
1069
 
 
1070
    bind = block->bind;
 
1071
    while (block) {
 
1072
        if (block->type == LispBlockClosure)
 
1073
            /* A function call */
 
1074
            break;
 
1075
        else if (block->type == LispBlockTag && block->tag == name)
 
1076
            break;
 
1077
        block = block->prev;
 
1078
        if (block)
 
1079
            bind += block->bind;
 
1080
    }
 
1081
 
 
1082
    if (!block || block->tag != name)
 
1083
        LispDestroy("%s: no visible %s block", STRFUN(builtin), STROBJ(name));
 
1084
 
 
1085
    /* Generate code to load result */
 
1086
    ComEval(com, result);
 
1087
 
 
1088
    /* Check for added variables that the jump is skiping the unbind opcode */
 
1089
    com_Unbind(com, bind);
 
1090
 
 
1091
    tree = NEW_TREE(CodeTreeReturn);
 
1092
    tree->data.block = block;
 
1093
}
 
1094
 
 
1095
/***********************************************************************
 
1096
 * Helper functions
 
1097
 ***********************************************************************/
 
1098
static int
 
1099
ComConstantp(LispCom *com, LispObj *object)
 
1100
{
 
1101
    switch (OBJECT_TYPE(object)) {
 
1102
        case LispAtom_t:
 
1103
            /* Keywords are guaranteed to evaluate to itself */
 
1104
            if (object->data.atom->package == lisp__data.keyword)
 
1105
                break;
 
1106
            return (0);
 
1107
 
 
1108
            /* Function call */
 
1109
        case LispCons_t:
 
1110
 
 
1111
            /* Need macro expansion, these are special abstract objects */
 
1112
        case LispQuote_t:
 
1113
        case LispBackquote_t:
 
1114
        case LispComma_t:
 
1115
        case LispFunctionQuote_t:
 
1116
            return (0);
 
1117
 
 
1118
            /* Anything else is a literal constant */
 
1119
        default:
 
1120
            break;
 
1121
    }
 
1122
 
 
1123
    return (1);
 
1124
}
 
1125
 
 
1126
static int
 
1127
FindIndex(void *item, void **table, int length)
 
1128
{
 
1129
    long cmp;
 
1130
    int left, right, i;
 
1131
 
 
1132
    left = 0;
 
1133
    right = length - 1;
 
1134
    while (left <= right) {
 
1135
        i = (left + right) >> 1;
 
1136
        cmp = (char*)item - (char*)table[i];
 
1137
        if (cmp == 0)
 
1138
            return (i);
 
1139
        else if (cmp < 0)
 
1140
            right = i - 1;
 
1141
        else
 
1142
            left = i + 1;
 
1143
    }
 
1144
 
 
1145
    return (-1);
 
1146
}
 
1147
 
 
1148
static int
 
1149
compare(const void *left, const void *right)
 
1150
{
 
1151
    long cmp = *(char**)left - *(char**)right;
 
1152
 
 
1153
    return (cmp < 0 ? -1 : 1);
 
1154
}
 
1155
 
 
1156
static int
 
1157
BuildTablePointer(void *pointer, void ***pointers, int *num_pointers)
 
1158
{
 
1159
    int i;
 
1160
 
 
1161
    if ((i = FindIndex(pointer, *pointers, *num_pointers)) < 0) {
 
1162
        *pointers = LispRealloc(*pointers,
 
1163
                                sizeof(void*) * (*num_pointers + 1));
 
1164
        (*pointers)[*num_pointers] = pointer;
 
1165
        if (++*num_pointers > 1)
 
1166
            qsort(*pointers, *num_pointers, sizeof(void*), compare);
 
1167
        i = FindIndex(pointer, *pointers, *num_pointers);
 
1168
    }
 
1169
 
 
1170
    return (i);
 
1171
}
 
1172
 
 
1173
static void
 
1174
ComAddVariable(LispCom *com, LispObj *symbol, LispObj *value)
 
1175
{
 
1176
    LispAtom *atom = symbol->data.atom;
 
1177
 
 
1178
    if (atom && atom->string && !com->macro) {
 
1179
        int i, length = com->block->variables.length;
 
1180
 
 
1181
        i = BuildTablePointer(atom, (void***)&com->block->variables.symbols,
 
1182
                              &com->block->variables.length);
 
1183
 
 
1184
        if (com->block->variables.length != length) {
 
1185
            com->block->variables.flags =
 
1186
                LispRealloc(com->block->variables.flags,
 
1187
                            com->block->variables.length * sizeof(int));
 
1188
 
 
1189
            /* Variable was inserted in the middle of the list */
 
1190
            if (i < length)
 
1191
                memmove(com->block->variables.flags + i + 1,
 
1192
                        com->block->variables.flags + i,
 
1193
                        (length - i) * sizeof(int));
 
1194
 
 
1195
            com->block->variables.flags[i] = 0;
 
1196
        }
 
1197
    }
 
1198
 
 
1199
    LispAddVar(symbol, value);
 
1200
}
 
1201
 
 
1202
static int
 
1203
ComGetVariable(LispCom *com, LispObj *symbol)
 
1204
{
 
1205
    LispAtom *name;
 
1206
    int i, base, offset;
 
1207
    Atom_id id;
 
1208
 
 
1209
    name = symbol->data.atom;
 
1210
    if (name->constant) {
 
1211
        if (name->package == lisp__data.keyword)
 
1212
            /*  Just load <symbol> from the byte stream, keywords are
 
1213
             * guaranteed to evaluate to itself. */
 
1214
            return (SYMBOL_KEYWORD);
 
1215
        return (SYMBOL_CONSTANT);
 
1216
    }
 
1217
 
 
1218
    offset = name->offset;
 
1219
    id = name->string;
 
1220
    base = lisp__data.env.lex;
 
1221
    i = lisp__data.env.head - 1;
 
1222
 
 
1223
    /* If variable is local */
 
1224
    if (offset <= i && offset >= com->lex && lisp__data.env.names[offset] == id) {
 
1225
        COM_VARIABLE_USED(name);
 
1226
        /* Relative offset */
 
1227
        return (offset - base);
 
1228
    }
 
1229
 
 
1230
    /* name->offset may have been changed in a macro expansion */
 
1231
    for (; i >= com->lex; i--)
 
1232
        if (lisp__data.env.names[i] == id) {
 
1233
            name->offset = i;
 
1234
            COM_VARIABLE_USED(name);
 
1235
            return (i - base);
 
1236
        }
 
1237
 
 
1238
    if (!name->a_object) {
 
1239
        ++com->warnings;
 
1240
        LispWarning("variable %s is neither declared nor bound",
 
1241
                    name->string);
 
1242
    }
 
1243
 
 
1244
    /* Not found, resolve <symbol> at run time */
 
1245
    return (SYMBOL_UNBOUND);
 
1246
}
 
1247
 
 
1248
static void
 
1249
ComVariableSetFlag(LispCom *com, LispAtom *atom, int flag)
 
1250
{
 
1251
    int i;
 
1252
    CodeBlock *block = com->block;
 
1253
 
 
1254
    while (block) {
 
1255
        i = FindIndex(atom, (void**)block->variables.symbols,
 
1256
                      block->variables.length);
 
1257
        if (i >= 0) {
 
1258
            block->variables.flags[i] |= flag;
 
1259
            /*  Descend block list if an argument to function being called
 
1260
             * has the same name as a bound variable in the current function.
 
1261
             */
 
1262
            if ((flag & VARIABLE_ARGUMENT) ||
 
1263
                !(block->variables.flags[i] & VARIABLE_ARGUMENT))
 
1264
                break;
 
1265
        }
 
1266
        block = block->prev;
 
1267
    }
 
1268
}
 
1269
 
 
1270
/***********************************************************************
 
1271
 * Bytecode compiler functions
 
1272
 ***********************************************************************/
 
1273
static void
 
1274
ComLabel(LispCom *com, LispObj *label)
 
1275
{
 
1276
    int i;
 
1277
    CodeTree *tree;
 
1278
 
 
1279
    for (i = 0; i < com->block->tagbody.length; i++)
 
1280
        if (label == com->block->tagbody.labels[i])
 
1281
            LispDestroy("TAGBODY: tag %s specified more than once",
 
1282
                        STROBJ(label));
 
1283
 
 
1284
    if (com->block->tagbody.length >= com->block->tagbody.space) {
 
1285
        com->block->tagbody.labels =
 
1286
            LispRealloc(com->block->tagbody.labels,
 
1287
                        sizeof(LispObj*) * (com->block->tagbody.space + 8));
 
1288
        /*  Reserve space, will be used at link time when
 
1289
         * resolving GO jumps. */
 
1290
        com->block->tagbody.codes =
 
1291
            LispRealloc(com->block->tagbody.codes,
 
1292
                        sizeof(CodeTree*) * (com->block->tagbody.space + 8));
 
1293
        com->block->tagbody.space += 8;
 
1294
    }
 
1295
 
 
1296
    com->block->tagbody.labels[com->block->tagbody.length++] = label;
 
1297
    tree = NEW_TREE(CodeTreeLabel);
 
1298
    tree->data.object = label;
 
1299
}
 
1300
 
 
1301
static void
 
1302
ComPush(LispCom *com, LispObj *symbol, LispObj *value,
 
1303
        int eval, int builtin, int compile)
 
1304
{
 
1305
    /*  If <compile> is set, it is pushing an argument to one of
 
1306
     * Com_XXX functions. */
 
1307
    if (compile) {
 
1308
        if (builtin)
 
1309
            lisp__data.stack.values[lisp__data.stack.length++] = value;
 
1310
        else
 
1311
            ComAddVariable(com, symbol, value);
 
1312
        return;
 
1313
    }
 
1314
 
 
1315
    /*  If <com->macro> is set, it is expanding a macro, just add the local
 
1316
     * variable <symbol> bounded to <value>, so that it will be available
 
1317
     * when calling the interpreter to expand the macro. */
 
1318
    else if (com->macro) {
 
1319
        ComAddVariable(com, symbol, value);
 
1320
        return;
 
1321
    }
 
1322
 
 
1323
    /*  If <eval> is set, it must generate the opcodes to evaluate <value>.
 
1324
     * If <value> is a constant, just generate the opcodes to load it. */
 
1325
    else if (eval && !ComConstantp(com, value)) {
 
1326
        switch (OBJECT_TYPE(value)) {
 
1327
            case LispAtom_t: {
 
1328
                int offset = ComGetVariable(com, value);
 
1329
 
 
1330
                if (offset >= 0) {
 
1331
                    /* Load <value> from user stack at the relative offset */
 
1332
                    if (builtin)
 
1333
                        com_LoadPush(com, offset);
 
1334
                    else
 
1335
                        com_LoadLet(com, offset, symbol->data.atom);
 
1336
                }
 
1337
                /* ComConstantp() does not return true for this, as the
 
1338
                 * current value must be computed. */
 
1339
                else if (offset == SYMBOL_CONSTANT) {
 
1340
                    value = value->data.atom->property->value;
 
1341
                    if (builtin)
 
1342
                        com_LoadConPush(com, value);
 
1343
                    else
 
1344
                        com_LoadConLet(com, value, symbol->data.atom);
 
1345
                }
 
1346
                else {
 
1347
                    /* Load value bound to <value> at run time */
 
1348
                    if (builtin)
 
1349
                        com_LoadSymPush(com, value->data.atom);
 
1350
                    else
 
1351
                        com_LoadSymLet(com, value->data.atom,
 
1352
                                       symbol->data.atom);
 
1353
                }
 
1354
            }   break;
 
1355
 
 
1356
            default:
 
1357
                /* Generate code to evaluate <value> */
 
1358
                ComEval(com, value);
 
1359
                if (builtin)
 
1360
                    com_Bytecode(com, XBC_PUSH);
 
1361
                else
 
1362
                    com_Let(com, symbol->data.atom);
 
1363
                break;
 
1364
        }
 
1365
 
 
1366
        /*  Remember <symbol> will be bound, <value> only matters for
 
1367
         * the Com_XXX  functions */
 
1368
        if (builtin)
 
1369
            lisp__data.stack.values[lisp__data.stack.length++] = value;
 
1370
        else
 
1371
            ComAddVariable(com, symbol, value);
 
1372
        return;
 
1373
    }
 
1374
 
 
1375
    if (builtin) {
 
1376
        /* Load <value> as a constant in builtin stack */
 
1377
        com_LoadConPush(com, value);
 
1378
        lisp__data.stack.values[lisp__data.stack.length++] = value;
 
1379
    }
 
1380
    else {
 
1381
        /* Load <value> as a constant in stack */
 
1382
        com_LoadConLet(com, value, symbol->data.atom);
 
1383
        /* Remember <symbol> will be bound */
 
1384
        ComAddVariable(com, symbol, value);
 
1385
    }
 
1386
}
 
1387
 
 
1388
/*  This function does almost the same job as LispMakeEnvironment, but
 
1389
 * it is not optimized for speed, as it is not building argument lists
 
1390
 * to user code, but to Com_XXX functions, or helping in generating the
 
1391
 * opcodes to load arguments at bytecode run time. */
 
1392
static int
 
1393
ComCall(LispCom *com, LispArgList *alist,
 
1394
        LispObj *name, LispObj *values,
 
1395
        int eval, int builtin, int compile)
 
1396
{
 
1397
    char *desc;
 
1398
    int i, count, base;
 
1399
    LispObj **symbols, **defaults, **sforms;
 
1400
 
 
1401
    if (builtin) {
 
1402
        base = lisp__data.stack.length;
 
1403
        /* This should never be executed, but make the check for safety */
 
1404
        if (base + alist->num_arguments > lisp__data.stack.space) {
 
1405
            do
 
1406
                LispMoreStack();
 
1407
            while (base + alist->num_arguments > lisp__data.stack.space);
 
1408
        }
 
1409
    }
 
1410
    else
 
1411
        base = lisp__data.env.length;
 
1412
 
 
1413
    desc = alist->description;
 
1414
    switch (*desc++) {
 
1415
        case '.':
 
1416
            goto normal_label;
 
1417
        case 'o':
 
1418
            goto optional_label;
 
1419
        case 'k':
 
1420
            goto key_label;
 
1421
        case 'r':
 
1422
            goto rest_label;
 
1423
        case 'a':
 
1424
            goto aux_label;
 
1425
        default:
 
1426
            goto done_label;
 
1427
    }
 
1428
 
 
1429
 
 
1430
    /* Normal arguments */
 
1431
normal_label:
 
1432
    i = 0;
 
1433
    symbols = alist->normals.symbols;
 
1434
    count = alist->normals.num_symbols;
 
1435
    for (; i < count && CONSP(values); i++, values = CDR(values)) {
 
1436
        ComPush(com, symbols[i], CAR(values), eval, builtin, compile);
 
1437
        if (!builtin && !com->macro)
 
1438
            COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
 
1439
    }
 
1440
    if (i < count)
 
1441
        LispDestroy("%s: too few arguments", STROBJ(name));
 
1442
 
 
1443
    switch (*desc++) {
 
1444
        case 'o':
 
1445
            goto optional_label;
 
1446
        case 'k':
 
1447
            goto key_label;
 
1448
        case 'r':
 
1449
            goto rest_label;
 
1450
        case 'a':
 
1451
            goto aux_label;
 
1452
        default:
 
1453
            goto done_label;
 
1454
    }
 
1455
 
 
1456
 
 
1457
    /* &OPTIONAL */
 
1458
optional_label:
 
1459
    i = 0;
 
1460
    count = alist->optionals.num_symbols;
 
1461
    symbols = alist->optionals.symbols;
 
1462
    defaults = alist->optionals.defaults;
 
1463
    sforms = alist->optionals.sforms;
 
1464
    for (; i < count && CONSP(values); i++, values = CDR(values)) {
 
1465
        ComPush(com, symbols[i], CAR(values), eval, builtin, compile);
 
1466
        if (!builtin && !com->macro)
 
1467
            COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
 
1468
        if (sforms[i]) {
 
1469
            ComPush(com, sforms[i], T, 0, builtin, compile);
 
1470
            if (!builtin && !com->macro)
 
1471
                COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
 
1472
        }
 
1473
    }
 
1474
    for (; i < count; i++) {
 
1475
        if (!builtin) {
 
1476
            int lex = com->lex;
 
1477
            int head = lisp__data.env.head;
 
1478
 
 
1479
            com->lex = base;
 
1480
            lisp__data.env.head = lisp__data.env.length;
 
1481
            /* default arguments are evaluated for macros */
 
1482
            ComPush(com, symbols[i], defaults[i], 1, 0, compile);
 
1483
            if (!com->macro)
 
1484
                COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
 
1485
            lisp__data.env.head = head;
 
1486
            com->lex = lex;
 
1487
        }
 
1488
        else
 
1489
            ComPush(com, symbols[i], defaults[i], eval, 1, compile);
 
1490
        if (sforms[i]) {
 
1491
            ComPush(com, sforms[i], NIL, 0, builtin, compile);
 
1492
            if (!builtin && !com->macro)
 
1493
                COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
 
1494
        }
 
1495
    }
 
1496
 
 
1497
    switch (*desc++) {
 
1498
        case 'k':
 
1499
            goto key_label;
 
1500
        case 'r':
 
1501
            goto rest_label;
 
1502
        case 'a':
 
1503
            goto aux_label;
 
1504
        default:
 
1505
            goto done_label;
 
1506
    }
 
1507
 
 
1508
 
 
1509
    /* &KEY */
 
1510
key_label:
 
1511
    {
 
1512
        int varset;
 
1513
        LispObj *val, *karg, **keys;
 
1514
 
 
1515
        count = alist->keys.num_symbols;
 
1516
        symbols = alist->keys.symbols;
 
1517
        defaults = alist->keys.defaults;
 
1518
        sforms = alist->keys.sforms;
 
1519
        keys = alist->keys.keys;
 
1520
 
 
1521
        /* Check if arguments are correctly specified */
 
1522
        for (karg = values; CONSP(karg); karg = CDR(karg)) {
 
1523
            val = CAR(karg);
 
1524
            if (KEYWORDP(val)) {
 
1525
                for (i = 0; i < alist->keys.num_symbols; i++)
 
1526
                    if (!keys[i] && symbols[i] == val)
 
1527
                        break;
 
1528
            }
 
1529
 
 
1530
            else if (!builtin &&
 
1531
                     QUOTEP(val) && SYMBOLP(val->data.quote)) {
 
1532
                for (i = 0; i < alist->keys.num_symbols; i++)
 
1533
                    if (keys[i] && ATOMID(keys[i]) == ATOMID(val->data.quote))
 
1534
                        break;
 
1535
            }
 
1536
 
 
1537
            else
 
1538
                /* Just make the error test true */
 
1539
                i = alist->keys.num_symbols;
 
1540
 
 
1541
            if (i == alist->keys.num_symbols) {
 
1542
                /* If not in argument specification list... */
 
1543
                char function_name[36];
 
1544
 
 
1545
                strcpy(function_name, STROBJ(name));
 
1546
                LispDestroy("%s: invalid keyword %s",
 
1547
                            function_name, STROBJ(val));
 
1548
            }
 
1549
 
 
1550
            karg = CDR(karg);
 
1551
            if (!CONSP(karg))
 
1552
                LispDestroy("%s: &KEY needs arguments as pairs",
 
1553
                            STROBJ(name));
 
1554
        }
 
1555
 
 
1556
        /* Add variables */
 
1557
        for (i = 0; i < alist->keys.num_symbols; i++) {
 
1558
            val = defaults[i];
 
1559
            varset = 0;
 
1560
            if (!builtin && keys[i]) {
 
1561
                Atom_id atom = ATOMID(keys[i]);
 
1562
 
 
1563
                /* Special keyword specification, need to compare ATOMID
 
1564
                 * and keyword specification must be a quoted object */
 
1565
                for (karg = values; CONSP(karg); karg = CDR(karg)) {
 
1566
                    val = CAR(karg);
 
1567
                    if (QUOTEP(val) && atom == ATOMID(val->data.quote)) {
 
1568
                        val = CADR(karg);
 
1569
                        varset = 1;
 
1570
                        break;
 
1571
                    }
 
1572
                    karg = CDR(karg);
 
1573
                }
 
1574
            }
 
1575
 
 
1576
            else {
 
1577
                /* Normal keyword specification, can compare object pointers,
 
1578
                 * as they point to the same object in the keyword package */
 
1579
                for (karg = values; CONSP(karg); karg = CDR(karg)) {
 
1580
                    /* Don't check if argument is a valid keyword or
 
1581
                     * special quoted keyword */
 
1582
                    if (symbols[i] == CAR(karg)) {
 
1583
                        val = CADR(karg);
 
1584
                        varset = 1;
 
1585
                        break;
 
1586
                    }
 
1587
                    karg = CDR(karg);
 
1588
                }
 
1589
            }
 
1590
 
 
1591
            /* Add the variable to environment */
 
1592
            if (varset) {
 
1593
                ComPush(com, symbols[i], val, eval, builtin, compile);
 
1594
                if (sforms[i])
 
1595
                    ComPush(com, sforms[i], T, 0, builtin, compile);
 
1596
            }
 
1597
            else {
 
1598
                /* default arguments are evaluated for macros */
 
1599
                if (!builtin) {
 
1600
                    int lex = com->lex;
 
1601
                    int head = lisp__data.env.head;
 
1602
 
 
1603
                    com->lex = base;
 
1604
                    lisp__data.env.head = lisp__data.env.length;
 
1605
                    ComPush(com, symbols[i], val, eval, 0, compile);
 
1606
                    lisp__data.env.head = head;
 
1607
                    com->lex = lex;
 
1608
                }
 
1609
                else
 
1610
                    ComPush(com, symbols[i], val, eval, builtin, compile);
 
1611
                if (sforms[i])
 
1612
                    ComPush(com, sforms[i], NIL, 0, builtin, compile);
 
1613
            }
 
1614
            if (!builtin && !com->macro) {
 
1615
                COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
 
1616
                if (sforms[i])
 
1617
                    COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
 
1618
            }
 
1619
        }
 
1620
    }
 
1621
 
 
1622
    if (*desc == 'a') {
 
1623
        /* &KEY uses all remaining arguments */
 
1624
        values = NIL;
 
1625
        goto aux_label;
 
1626
    }
 
1627
    goto finished_label;
 
1628
 
 
1629
 
 
1630
    /* &REST */
 
1631
rest_label:
 
1632
    if (!eval || !CONSP(values) || (compile && !builtin))
 
1633
        ComPush(com, alist->rest, values, eval, builtin, compile);
 
1634
    else {
 
1635
        char *string;
 
1636
        LispObj *list, *car = NIL;
 
1637
        int count, constantp;
 
1638
 
 
1639
        /* Count number of arguments and check if it is a list of constants */
 
1640
        for (count = 0, constantp = 1, list = values;
 
1641
             CONSP(list);
 
1642
             list = CDR(list), count++) {
 
1643
            car = CAR(list);
 
1644
            if (!ComConstantp(com, car))
 
1645
                constantp = 0;
 
1646
        }
 
1647
 
 
1648
        string = builtin ? ATOMID(name) : NULL;
 
1649
        /* XXX FIXME should have a flag indicating if function call
 
1650
         * change the &REST arguments even if it is a constant list
 
1651
         * (or if the returned value may be changed). */
 
1652
        if (string && (count < MAX_BCONS || constantp) &&
 
1653
            strcmp(string, "LIST") &&
 
1654
            strcmp(string, "APPLY") &&  /* XXX depends on function argument */
 
1655
            strcmp(string, "VECTOR") &&
 
1656
            /* Append does not copy the last/single list */
 
1657
            (strcmp(string, "APPEND") || !CONSP(car))) {
 
1658
            if (constantp) {
 
1659
                /* If the builtin function changes the &REST parameters, must
 
1660
                 * define a Com_XXX function for it. */
 
1661
                ComPush(com, alist->rest, values, 0, builtin, compile);
 
1662
            }
 
1663
            else {
 
1664
                CompileStackEnter(com, count - 1, 1);
 
1665
                for (; CONSP(CDR(values)); values = CDR(values)) {
 
1666
                    /* Evaluate this argument */
 
1667
                    ComEval(com, CAR(values));
 
1668
                    /* Save result in builtin stack */
 
1669
                    com_Bytecode(com, XBC_PUSH);
 
1670
                }
 
1671
                CompileStackLeave(com, count - 1, 1);
 
1672
                /* The last argument is not saved in the stack */
 
1673
                ComEval(com, CAR(values));
 
1674
                values = NIL;
 
1675
                com_Bytecode(com, XBC_BCONS + (count - 1));
 
1676
            }
 
1677
        }
 
1678
        else {
 
1679
            /* Allocate a fresh list of cons */
 
1680
 
 
1681
            /* Generate code to load object */
 
1682
            ComEval(com, CAR(values));
 
1683
 
 
1684
            com->stack.cpstack += 2;
 
1685
            if (com->stack.pstack < com->stack.cpstack)
 
1686
                com->stack.pstack = com->stack.cpstack;
 
1687
            /* Start building a gc protected list, with the loaded value */
 
1688
            com_Bytecode(com, XBC_LSTAR);
 
1689
 
 
1690
            for (values = CDR(values); CONSP(values); values = CDR(values)) {
 
1691
                /* Generate code to load object */
 
1692
                ComEval(com, CAR(values));
 
1693
 
 
1694
                /* Add loaded value to gc protected list */
 
1695
                com_Bytecode(com, XBC_LCONS);
 
1696
            }
 
1697
 
 
1698
            /* Finish gc protected list */
 
1699
            com_Bytecode(com, XBC_LFINI);
 
1700
 
 
1701
            /* Push loaded value */
 
1702
            if (builtin)
 
1703
                com_Bytecode(com, XBC_PUSH);
 
1704
            else {
 
1705
                com_Let(com, alist->rest->data.atom);
 
1706
 
 
1707
                /* Remember this symbol will be bound */
 
1708
                ComAddVariable(com, alist->rest, values);
 
1709
            }
 
1710
            com->stack.cpstack -= 2;
 
1711
        }
 
1712
    }
 
1713
    if (!builtin && !com->macro)
 
1714
        COM_VARIABLE_ARGUMENT(alist->rest->data.atom);
 
1715
    if (*desc != 'a')
 
1716
        goto finished_label;
 
1717
 
 
1718
 
 
1719
    /* &AUX */
 
1720
aux_label:
 
1721
    i = 0;
 
1722
    count = alist->auxs.num_symbols;
 
1723
    symbols = alist->auxs.symbols;
 
1724
    defaults = alist->auxs.initials;
 
1725
    if (!builtin && !compile) {
 
1726
        int lex = com->lex;
 
1727
 
 
1728
        com->lex = base;
 
1729
        lisp__data.env.head = lisp__data.env.length;
 
1730
        for (; i < count; i++) {
 
1731
            ComPush(com, symbols[i], defaults[i], 1, 0, 0);
 
1732
            if (!com->macro)
 
1733
                COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
 
1734
            ++lisp__data.env.head;
 
1735
        }
 
1736
        com->lex = lex;
 
1737
    }
 
1738
    else {
 
1739
        for (; i < count; i++) {
 
1740
            ComPush(com, symbols[i], defaults[i], eval, builtin, compile);
 
1741
            if (!builtin && !com->macro)
 
1742
                COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
 
1743
        }
 
1744
    }
 
1745
 
 
1746
done_label:
 
1747
    if (CONSP(values))
 
1748
        LispDestroy("%s: too many arguments", STROBJ(name));
 
1749
 
 
1750
finished_label:
 
1751
    if (builtin)
 
1752
        lisp__data.stack.base = base;
 
1753
    else
 
1754
        lisp__data.env.head = lisp__data.env.length;
 
1755
 
 
1756
    return (base);
 
1757
}
 
1758
 
 
1759
static void
 
1760
ComFuncall(LispCom *com, LispObj *function, LispObj *arguments, int eval)
 
1761
{
 
1762
    int base, compile;
 
1763
    LispAtom *atom;
 
1764
    LispArgList *alist;
 
1765
    LispBuiltin *builtin;
 
1766
    LispObj *lambda;
 
1767
 
 
1768
    switch (OBJECT_TYPE(function)) {
 
1769
        case LispFunction_t:
 
1770
            function = function->data.atom->object;
 
1771
        case LispAtom_t:
 
1772
            atom = function->data.atom;
 
1773
            alist = atom->property->alist;
 
1774
 
 
1775
            if (atom->a_builtin) {
 
1776
                builtin = atom->property->fun.builtin;
 
1777
                compile = builtin->compile != NULL;
 
1778
 
 
1779
                /*  If one of:
 
1780
                 *      o expanding a macro
 
1781
                 *      o calling a builtin special form
 
1782
                 *      o builtin function is a macro
 
1783
                 * don't evaluate arguments. */
 
1784
                if (com->macro || compile || builtin->type == LispMacro)
 
1785
                    eval = 0;
 
1786
 
 
1787
                if (!com->macro && builtin->type == LispMacro) {
 
1788
                    /* Set flag of variable used, in case variable is only
 
1789
                     * used as a builtin macro argument. */
 
1790
                    LispObj *obj;
 
1791
 
 
1792
                    for (obj = arguments; CONSP(obj); obj = CDR(obj)) {
 
1793
                        if (SYMBOLP(CAR(obj)))
 
1794
                            COM_VARIABLE_USED(CAR(obj)->data.atom);
 
1795
                    }
 
1796
                }
 
1797
 
 
1798
                FORM_ENTER();
 
1799
                if (!compile && !com->macro)
 
1800
                    CompileStackEnter(com, alist->num_arguments, 1);
 
1801
 
 
1802
                /* Build argument list in the interpreter stacks */
 
1803
                base = ComCall(com, alist, function, arguments,
 
1804
                               eval, 1, compile);
 
1805
 
 
1806
                /* If <compile> is set, it is a special form */
 
1807
                if (compile)
 
1808
                    builtin->compile(com, builtin);
 
1809
 
 
1810
                /* Else, generate opcodes to call builtin function */
 
1811
                else {
 
1812
                    com_Call(com, alist->num_arguments, builtin);
 
1813
                    CompileStackLeave(com, alist->num_arguments, 1);
 
1814
                }
 
1815
                lisp__data.stack.base = lisp__data.stack.length = base;
 
1816
                FORM_LEAVE();
 
1817
            }
 
1818
            else if (atom->a_function) {
 
1819
                int macro;
 
1820
 
 
1821
                lambda = atom->property->fun.function;
 
1822
                macro = lambda->funtype == LispMacro;
 
1823
 
 
1824
                /* If <macro> is set, expand macro */
 
1825
                if (macro)
 
1826
                    ComMacroCall(com, alist, function, lambda, arguments);
 
1827
 
 
1828
                else {
 
1829
                    if (com->toplevel->type == LispBlockClosure &&
 
1830
                        com->toplevel->tag == function)
 
1831
                        ComRecursiveCall(com, alist, function, arguments);
 
1832
                    else {
 
1833
#if 0
 
1834
                        ComInlineCall(com, alist, function, arguments,
 
1835
                                      lambda->data.lambda.code);
 
1836
#else
 
1837
                        com_Funcall(com, function, arguments);
 
1838
#endif
 
1839
                    }
 
1840
                }
 
1841
            }
 
1842
            else if (atom->a_defstruct &&
 
1843
                     atom->property->structure.function != STRUCT_NAME &&
 
1844
                     atom->property->structure.function != STRUCT_CONSTRUCTOR) {
 
1845
                LispObj *definition = atom->property->structure.definition;
 
1846
 
 
1847
                if (!CONSP(arguments) || CONSP(CDR(arguments)))
 
1848
                    LispDestroy("%s: too %s arguments", atom->string,
 
1849
                                CONSP(arguments) ? "many" : "few");
 
1850
 
 
1851
                ComEval(com, CAR(arguments));
 
1852
                if (atom->property->structure.function == STRUCT_CHECK)
 
1853
                    com_Structp(com, definition);
 
1854
                else
 
1855
                    com_Struct(com,
 
1856
                               atom->property->structure.function, definition);
 
1857
            }
 
1858
            else if (atom->a_compiled) {
 
1859
                FORM_ENTER();
 
1860
                CompileStackEnter(com, alist->num_arguments, 0);
 
1861
 
 
1862
                /* Build argument list in the interpreter stacks */
 
1863
                base = ComCall(com, alist, function, arguments, 1, 0, 0);
 
1864
                com_Bytecall(com, alist->num_arguments,
 
1865
                             atom->property->fun.function);
 
1866
                CompileStackLeave(com, alist->num_arguments, 0);
 
1867
                lisp__data.env.head = lisp__data.env.length = base;
 
1868
                FORM_LEAVE();
 
1869
            }
 
1870
            else {
 
1871
                /* Not yet defined function/macro. */
 
1872
                ++com->warnings;
 
1873
                LispWarning("call to undefined function %s", atom->string);
 
1874
                com_Funcall(com, function, arguments);
 
1875
            }
 
1876
            break;
 
1877
 
 
1878
        case LispLambda_t:
 
1879
            lambda = function->data.lambda.code;
 
1880
            alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
 
1881
            ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code);
 
1882
            break;
 
1883
 
 
1884
        case LispCons_t:
 
1885
            if (CAR(function) == Olambda) {
 
1886
                function = EVAL(function);
 
1887
                if (LAMBDAP(function)) {
 
1888
                    GC_ENTER();
 
1889
 
 
1890
                    GC_PROTECT(function);
 
1891
                    lambda = function->data.lambda.code;
 
1892
                    alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
 
1893
                    ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code);
 
1894
                    GC_LEAVE();
 
1895
                    break;
 
1896
                }
 
1897
            }
 
1898
 
 
1899
        default:
 
1900
            /*  XXX If bytecode objects are made available, should
 
1901
             * handle it here. */
 
1902
            LispDestroy("EVAL: %s is invalid as a function",
 
1903
                        STROBJ(function));
 
1904
            /*NOTREACHED*/
 
1905
            break;
 
1906
    }
 
1907
}
 
1908
 
 
1909
/* Generate opcodes for an implicit PROGN */
 
1910
static void
 
1911
ComProgn(LispCom *com, LispObj *code)
 
1912
{
 
1913
    if (CONSP(code)) {
 
1914
        for (; CONSP(code); code = CDR(code))
 
1915
            ComEval(com, CAR(code));
 
1916
    }
 
1917
    else
 
1918
        /* If no code to execute, empty PROGN returns NIL */
 
1919
        com_Bytecode(com, XBC_NIL);
 
1920
}
 
1921
 
 
1922
/* Generate opcodes to evaluate <object>. */
 
1923
static void
 
1924
ComEval(LispCom *com, LispObj *object)
 
1925
{
 
1926
    int offset;
 
1927
    LispObj *form;
 
1928
 
 
1929
    switch (OBJECT_TYPE(object)) {
 
1930
        case LispAtom_t:
 
1931
            if (IN_TAGBODY())
 
1932
                ComLabel(com, object);
 
1933
            else {
 
1934
                offset = ComGetVariable(com, object);
 
1935
                if (offset >= 0)
 
1936
                    /* Load from user stack at relative offset */
 
1937
                    com_Load(com, offset);
 
1938
                else if (offset == SYMBOL_KEYWORD)
 
1939
                    com_LoadCon(com, object);
 
1940
                else if (offset == SYMBOL_CONSTANT)
 
1941
                    /* Symbol defined as constant, just load it's value */
 
1942
                    com_LoadCon(com, LispGetVar(object));
 
1943
                else
 
1944
                    /* Load value bound to symbol at run time */
 
1945
                    com_LoadSym(com, object->data.atom);
 
1946
            }
 
1947
            break;
 
1948
 
 
1949
        case LispCons_t: {
 
1950
            /* Macro expansion may be done in the object form */
 
1951
            form = com->form;
 
1952
            com->form = object;
 
1953
            ComFuncall(com, CAR(object), CDR(object), 1);
 
1954
            com->form = form;
 
1955
        }   break;
 
1956
 
 
1957
        case LispQuote_t:
 
1958
            com_LoadCon(com, object->data.quote);
 
1959
            break;
 
1960
 
 
1961
        case LispBackquote_t:
 
1962
            /* Macro expansion is stored in the current value of com->form */
 
1963
            ComMacroBackquote(com, object);
 
1964
            break;
 
1965
 
 
1966
        case LispComma_t:
 
1967
            LispDestroy("EVAL: comma outside of backquote");
 
1968
            break;
 
1969
 
 
1970
        case LispFunctionQuote_t:
 
1971
            object = object->data.quote;
 
1972
            if (SYMBOLP(object))
 
1973
                object = LispSymbolFunction(object);
 
1974
            else if (CONSP(object) && CAR(object) == Olambda) {
 
1975
                /* object will only be associated with bytecode later,
 
1976
                 * so, make sure it is protected until compilation finishes */
 
1977
                object = EVAL(object);
 
1978
                RPLACD(com->plist, CONS(CAR(com->plist), CDR(com->plist)));
 
1979
                RPLACA(com->plist, object);
 
1980
            }
 
1981
            else
 
1982
                LispDestroy("FUNCTION: %s is not a function", STROBJ(object));
 
1983
            com_LoadCon(com, object);
 
1984
            break;
 
1985
 
 
1986
        case LispFixnum_t:
 
1987
            if (IN_TAGBODY()) {
 
1988
                ComLabel(com, object);
 
1989
                break;
 
1990
            }
 
1991
            /*FALLTROUGH*/
 
1992
 
 
1993
        default:
 
1994
            /* Constant object */
 
1995
            com_LoadCon(com, object);
 
1996
            break;
 
1997
    }
 
1998
}
 
1999
 
 
2000
/***********************************************************************
 
2001
 * Lambda expansion helper functions
 
2002
 ***********************************************************************/
 
2003
static void
 
2004
ComRecursiveCall(LispCom *com, LispArgList *alist,
 
2005
                 LispObj *name, LispObj *arguments)
 
2006
{
 
2007
    int base, lex;
 
2008
 
 
2009
    /* Save state */
 
2010
    lex = lisp__data.env.lex;
 
2011
 
 
2012
    FORM_ENTER();
 
2013
 
 
2014
    /* Generate code to push function arguments in the stack */
 
2015
    base = ComCall(com, alist, name, arguments, 1, 0, 0);
 
2016
 
 
2017
    /* Stack will grow this amount */
 
2018
    CompileStackEnter(com, alist->num_arguments, 0);
 
2019
 
 
2020
#if 0
 
2021
    /* Make the variables available at run time */
 
2022
    com_Bind(com, alist->num_arguments);
 
2023
    com->block->bind += alist->num_arguments;
 
2024
#endif
 
2025
 
 
2026
    com_BytecodeChar(com, XBC_LETREC, alist->num_arguments);
 
2027
 
 
2028
#if 0
 
2029
    /* The variables are now unbound */
 
2030
    com_Unbind(com, alist->num_arguments);
 
2031
    com->block->bind -= alist->num_arguments;
 
2032
#endif
 
2033
 
 
2034
    /* Stack length is reduced */
 
2035
    CompileStackLeave(com, alist->num_arguments, 0);
 
2036
    FORM_LEAVE();
 
2037
 
 
2038
    /* Restore state */
 
2039
    lisp__data.env.lex = lex;
 
2040
    lisp__data.env.head = lisp__data.env.length = base;
 
2041
}
 
2042
 
 
2043
static void
 
2044
ComInlineCall(LispCom *com, LispArgList *alist,
 
2045
              LispObj *name, LispObj *arguments, LispObj *lambda)
 
2046
{
 
2047
    int base, lex;
 
2048
 
 
2049
    /* Save state */
 
2050
    lex = lisp__data.env.lex;
 
2051
 
 
2052
    FORM_ENTER();
 
2053
    /* Start the inline function block */
 
2054
    CompileIniBlock(com, LispBlockClosure, name);
 
2055
 
 
2056
    /* Generate code to push function arguments in the stack */
 
2057
    base = ComCall(com, alist, name, arguments, 1, 0, 0);
 
2058
 
 
2059
    /* Stack will grow this amount */
 
2060
    CompileStackEnter(com, alist->num_arguments, 0);
 
2061
 
 
2062
    /* Make the variables available at run time */
 
2063
    com_Bind(com, alist->num_arguments);
 
2064
    com->block->bind += alist->num_arguments;
 
2065
 
 
2066
    /* Expand the lambda list */
 
2067
    ComProgn(com, lambda);
 
2068
 
 
2069
    /* The variables are now unbound */
 
2070
    com_Unbind(com, alist->num_arguments);
 
2071
    com->block->bind -= alist->num_arguments;
 
2072
 
 
2073
    /* Stack length is reduced */
 
2074
    CompileStackLeave(com, alist->num_arguments, 0);
 
2075
 
 
2076
    /* Finish the inline function block */
 
2077
    CompileFiniBlock(com);
 
2078
    FORM_LEAVE();
 
2079
 
 
2080
    /* Restore state */
 
2081
    lisp__data.env.lex = lex;
 
2082
    lisp__data.env.head = lisp__data.env.length = base;
 
2083
}
 
2084
 
 
2085
/***********************************************************************
 
2086
 * Macro expansion helper functions.
 
2087
 ***********************************************************************/
 
2088
static LispObj *
 
2089
ComMacroExpandBackquote(LispCom *com, LispObj *object)
 
2090
{
 
2091
    return (LispEvalBackquote(object->data.quote, 1));
 
2092
}
 
2093
 
 
2094
static LispObj *
 
2095
ComMacroExpandFuncall(LispCom *com, LispObj *function, LispObj *arguments)
 
2096
{
 
2097
    return (LispFuncall(function, arguments, 1));
 
2098
}
 
2099
 
 
2100
static LispObj *
 
2101
ComMacroExpandEval(LispCom *com, LispObj *object)
 
2102
{
 
2103
    LispObj *result;
 
2104
 
 
2105
    switch (OBJECT_TYPE(object)) {
 
2106
        case LispAtom_t:
 
2107
            result = LispGetVar(object);
 
2108
 
 
2109
            /* Macro expansion requires bounded symbols */
 
2110
            if (result == NULL)
 
2111
                LispDestroy("EVAL: the variable %s is unbound",
 
2112
                            STROBJ(object));
 
2113
            break;
 
2114
 
 
2115
        case LispCons_t:
 
2116
            result = ComMacroExpandFuncall(com, CAR(object), CDR(object));
 
2117
            break;
 
2118
 
 
2119
        case LispQuote_t:
 
2120
            result = object->data.quote;
 
2121
            break;
 
2122
 
 
2123
        case LispBackquote_t:
 
2124
            result = ComMacroExpandBackquote(com, object);
 
2125
            break;
 
2126
 
 
2127
        case LispComma_t:
 
2128
            LispDestroy("EVAL: comma outside of backquote");
 
2129
 
 
2130
        case LispFunctionQuote_t:
 
2131
            result = EVAL(object);
 
2132
            break;
 
2133
 
 
2134
        default:
 
2135
            result = object;
 
2136
            break;
 
2137
    }
 
2138
 
 
2139
    return (result);
 
2140
}
 
2141
 
 
2142
static LispObj *
 
2143
ComMacroExpand(LispCom *com, LispObj *lambda)
 
2144
{
 
2145
    LispObj *result, **presult = &result, **plambda;
 
2146
    int jumped, *pjumped = &jumped, backquote, *pbackquote = &backquote;
 
2147
    LispBlock *block;
 
2148
 
 
2149
    int interpreter_lex, interpreter_head, interpreter_base;
 
2150
 
 
2151
    /* Save interpreter state */
 
2152
    interpreter_base = lisp__data.stack.length;
 
2153
    interpreter_head = lisp__data.env.length;
 
2154
    interpreter_lex = lisp__data.env.lex;
 
2155
 
 
2156
    /* Use the variables */
 
2157
    plambda = &lambda;
 
2158
    *presult = NIL;
 
2159
    *pjumped = 1;
 
2160
    *pbackquote = !CONSP(lambda);
 
2161
 
 
2162
    block = LispBeginBlock(NIL, LispBlockProtect);
 
2163
    if (setjmp(block->jmp) == 0) {
 
2164
        if (!backquote) {
 
2165
            for (; CONSP(lambda); lambda = CDR(lambda))
 
2166
                result = ComMacroExpandEval(com, CAR(lambda));
 
2167
        }
 
2168
        else
 
2169
            result = ComMacroExpandBackquote(com, lambda);
 
2170
 
 
2171
        *pjumped = 0;
 
2172
    }
 
2173
    LispEndBlock(block);
 
2174
 
 
2175
    /* If tried to jump out of the macro expansion block */
 
2176
    if (!lisp__data.destroyed && jumped)
 
2177
        LispDestroy("*** EVAL: bad jump in macro expansion");
 
2178
 
 
2179
    /* Macro expansion did something wrong */
 
2180
    if (lisp__data.destroyed) {
 
2181
        LispMessage("*** EVAL: aborting macro expansion");
 
2182
        LispDestroy(".");
 
2183
    }
 
2184
 
 
2185
    /* Restore interpreter state */
 
2186
    lisp__data.env.lex = interpreter_lex;
 
2187
    lisp__data.stack.length = interpreter_base;
 
2188
    lisp__data.env.head = lisp__data.env.length = interpreter_head;
 
2189
 
 
2190
    return (result);
 
2191
}
 
2192
 
 
2193
static void
 
2194
ComMacroCall(LispCom *com, LispArgList *alist,
 
2195
             LispObj *name, LispObj *lambda, LispObj *arguments)
 
2196
{
 
2197
    int base;
 
2198
    LispObj *body;
 
2199
 
 
2200
    ++com->macro;
 
2201
    base = ComCall(com, alist, name, arguments, 0, 0, 0);
 
2202
    body = lambda->data.lambda.code;
 
2203
    body = ComMacroExpand(com, body);
 
2204
    --com->macro;
 
2205
    lisp__data.env.head = lisp__data.env.length = base;
 
2206
 
 
2207
    /* Macro is expanded, store the result */
 
2208
    CAR(com->form) = body;
 
2209
    ComEval(com, body);
 
2210
}
 
2211
 
 
2212
static void
 
2213
ComMacroBackquote(LispCom *com, LispObj *lambda)
 
2214
{
 
2215
    LispObj *body;
 
2216
 
 
2217
    ++com->macro;
 
2218
    body = ComMacroExpand(com, lambda);
 
2219
    --com->macro;
 
2220
 
 
2221
    /* Macro is expanded, store the result */
 
2222
    CAR(com->form) = body;
 
2223
 
 
2224
    com_LoadCon(com, body);
 
2225
}