← Back to branch summary

~ubuntu-branches/ubuntu/lucid/graphviz/lucid-security

« back to all changes in this revision

Viewing changes to lefty/exec.c

  • Committer: Bazaar Package Importer
  • Author(s): Stephen M Moraco
  • Date: 2002-02-05 18:52:12 UTC
  • Revision ID: james.westby@ubuntu.com-20020205185212-8i04c70te00rc40y
Tags: upstream-1.7.16
Import upstream version 1.7.16

Show diffs side-by-side

added added

removed removed

Lines of Context:
lefty/exec.c
 
1
/*
 
2
    This software may only be used by you under license from AT&T Corp.
 
3
    ("AT&T").  A copy of AT&T's Source Code Agreement is available at
 
4
    AT&T's Internet website having the URL:
 
5
    <http://www.research.att.com/sw/tools/graphviz/license/source.html>
 
6
    If you received this software without first entering into a license
 
7
    with AT&T, you have an infringing copy of this software and cannot use
 
8
    it without violating AT&T's intellectual property rights.
 
9
*/
 
10
 
 
11
#pragma prototyped
 
12
/* Lefteris Koutsofios - AT&T Bell Laboratories */
 
13
 
 
14
#include "common.h"
 
15
#include "mem.h"
 
16
#include "code.h"
 
17
#include "tbl.h"
 
18
#include "str.h"
 
19
#include "exec.h"
 
20
#include "internal.h"
 
21
 
 
22
static lvar_t *lvarp;
 
23
static int lvarn, llvari, flvari;
 
24
#define LVARINCR 1000
 
25
#define LVARSIZE sizeof (lvar_t)
 
26
 
 
27
Tobj root, null;
 
28
Tobj rtno;
 
29
int Erun;
 
30
int Eerrlevel, Estackdepth, Eshowbody, Eshowcalls, Eoktorun;
 
31
 
 
32
#define PUSHJMP(op, np, b) op = (volatile jmp_buf *) np, np = (jmp_buf *) &b
 
33
#define POPJMP(op, np) np = (jmp_buf *) op
 
34
 
 
35
/* longjmps for normal program execution */
 
36
typedef enum {
 
37
    PLJ_BREAK, PLJ_CONTINUE, PLJ_RETURN, PLJ_SIZE
 
38
} PLJtype_t;
 
39
static jmp_buf *pljbufp1, *pljbufp2;
 
40
static PLJtype_t pljtype;
 
41
 
 
42
/* longjmp for error handling */
 
43
static jmp_buf *eljbufp;
 
44
 
 
45
/* error levels and types */
 
46
typedef enum {
 
47
    ERR0, ERR1, ERR2, ERR3, ERR4, ERR5
 
48
} errlevel_t;
 
49
typedef enum {
 
50
    ERRNOLHS, ERRNORHS, ERRNOSUCHFUNC, ERRBADARG, ERRARGMIS, ERRNOTATABLE,
 
51
    ERRIFUNCERR, ERRRECRUN, ERRTABLECHANGED
 
52
} errnum_t;
 
53
static char *errnam[] = {
 
54
    "no variable",
 
55
    "no value",
 
56
    "no such function",
 
57
    "bad argument",
 
58
    "argument number mismatch",
 
59
    "not a table",
 
60
    "internal function call error",
 
61
    "recursive run attempt",
 
62
    "table changed during a forin loop",
 
63
};
 
64
 
 
65
static int errdo;
 
66
 
 
67
/* stack information */
 
68
typedef struct sinfo_t {
 
69
    Tobj co, fco;
 
70
    int ci, fci;
 
71
    int flvari, llvari;
 
72
} sinfo_t;
 
73
#define SINFOSIZE sizeof (sinfo_t)
 
74
#define SINFOINCR 100
 
75
static sinfo_t *sinfop;
 
76
static int sinfoi, sinfon;
 
77
 
 
78
typedef enum {
 
79
    TNK_LI, TNK_O, TNK_S
 
80
} tnktype_t;
 
81
typedef struct tnk_t {
 
82
    tnktype_t type;
 
83
    union {
 
84
        int li;
 
85
        struct {
 
86
            Tobj to, ko;
 
87
        } tnko;
 
88
        struct {
 
89
            Ctype_t kt;
 
90
            Tobj to, co;
 
91
            int vi;
 
92
        } tnks;
 
93
    } u;
 
94
} tnk_t;
 
95
 
 
96
typedef struct Num_t {
 
97
    Ctype_t type;
 
98
    union {
 
99
        long i;
 
100
        double d;
 
101
        Tobj no;
 
102
    } u;
 
103
} Num_t;
 
104
 
 
105
static long rootm;
 
106
static int running;
 
107
 
 
108
static Tobj eeval (Tobj, int);
 
109
static Tobj efcall (Tobj, int);
 
110
static void ewhilest (Tobj, int);
 
111
static void eforst (Tobj, int);
 
112
static void eforinst (Tobj, int);
 
113
 
 
114
static Tobj getval (Tobj, int);
 
115
static int getvar (Tobj, int, tnk_t *);
 
116
static void setvar (tnk_t, Tobj);
 
117
static int boolop (Tobj);
 
118
static int orderop (Tobj, Ctype_t, Tobj);
 
119
static Tobj arithop (Num_t *, Ctype_t, Num_t *);
 
120
static void err (int, int, Tobj, int);
 
121
static void printbody (char *, int);
 
122
 
 
123
void Einit (void) {
 
124
    root = Ttable (100);
 
125
    rootm = Mpushmark (root);
 
126
    Tinss (root, "null", (null = Ttable (2)));
 
127
    rtno = NULL;
 
128
    pljbufp1 = pljbufp2 = NULL, pljtype = 0;
 
129
    eljbufp = NULL;
 
130
    lvarp = Marrayalloc ((long) LVARINCR * LVARSIZE);
 
131
    lvarn = LVARINCR;
 
132
    llvari = 0;
 
133
    flvari = 0;
 
134
    sinfop = Marrayalloc ((long) SINFOINCR * SINFOSIZE);
 
135
    sinfon = SINFOINCR;
 
136
    sinfoi = 0;
 
137
    Erun = FALSE;
 
138
    running = 0;
 
139
    Eoktorun = FALSE;
 
140
}
 
141
 
 
142
void Eterm (void) {
 
143
    Marrayfree (sinfop), sinfop = NULL, sinfon = 0, sinfoi = 0;
 
144
    Marrayfree (lvarp), lvarp = NULL, lvarn = 0, llvari = 0, flvari = 0;
 
145
    rtno = NULL;
 
146
    null = NULL;
 
147
    Mpopmark (rootm);
 
148
}
 
149
 
 
150
Tobj Eunit (Tobj co) {
 
151
    volatile jmp_buf *oeljbufp;
 
152
    volatile int ownsinfoi;
 
153
    volatile long m;
 
154
    volatile Tobj lrtno;
 
155
 
 
156
    jmp_buf eljbuf;
 
157
 
 
158
#if 0
 
159
    if (running && !Eoktorun) {
 
160
        err (ERRRECRUN, ERR2, NULL, 0);
 
161
        return NULL;
 
162
    }
 
163
#endif
 
164
    Eoktorun = FALSE;
 
165
 
 
166
    if (!co)
 
167
        return NULL;
 
168
 
 
169
    if (Tgettype (co) != T_CODE)
 
170
        panic (POS, "Eunit", "argument type is not T_CODE");
 
171
 
 
172
    m = Mpushmark (co);
 
173
    PUSHJMP (oeljbufp, eljbufp, eljbuf);
 
174
    ownsinfoi = sinfoi++;
 
175
    if (sinfoi == sinfon) {
 
176
        sinfop = Marraygrow (sinfop, (long) (sinfon + SINFOINCR) * SINFOSIZE);
 
177
        sinfon += SINFOINCR;
 
178
    }
 
179
    sinfop[ownsinfoi].co = co;
 
180
    sinfop[ownsinfoi].ci = TCgetfp (co, 0);
 
181
    sinfop[ownsinfoi].fco = NULL;
 
182
    sinfop[ownsinfoi].flvari = flvari;
 
183
    sinfop[ownsinfoi].llvari = llvari;
 
184
    running++;
 
185
    if (setjmp (*eljbufp))
 
186
        lrtno = NULL;
 
187
    else
 
188
        lrtno = eeval (co, TCgetfp (co, 0));
 
189
    running--;
 
190
    rtno = NULL;
 
191
    flvari = sinfop[ownsinfoi].flvari;
 
192
    llvari = sinfop[ownsinfoi].llvari;
 
193
    sinfoi = ownsinfoi;
 
194
    POPJMP (oeljbufp, eljbufp);
 
195
    Mpopmark (m);
 
196
    Erun = TRUE;
 
197
    return lrtno;
 
198
}
 
199
 
 
200
/* shortcut: this function executes a piece of code that corresponds to
 
201
   <internal func name> = function () internal "<internal func name>";
 
202
*/
 
203
Tobj Efunction (Tobj co, char *ifnam) {
 
204
    Tobj v1o;
 
205
    int fi;
 
206
 
 
207
    fi = TCgetnext (co, TCgetfp (co, TCgetfp (co, 0)));
 
208
    v1o = Tcode (TCgetaddr (co, fi), fi,
 
209
            (int) TCgetinteger (co, TCgetfp (co, fi)));
 
210
    Tinss (root, ifnam, v1o);
 
211
    return v1o;
 
212
}
 
213
 
 
214
static Tobj eeval (Tobj co, int ci) {
 
215
    Tobj v1o, v2o, v3o;
 
216
    Ttype_t ttype;
 
217
    Ctype_t ctype;
 
218
    tnk_t tnk;
 
219
    Num_t lnum, rnum;
 
220
    long m1, m2;
 
221
    int i1, i2, res;
 
222
 
 
223
tailrec:
 
224
    errdo = TRUE;
 
225
    v1o = NULL;
 
226
    ctype = TCgettype (co, ci);
 
227
    switch (ctype) {
 
228
    case C_ASSIGN:
 
229
        i1 = TCgetfp (co, ci);
 
230
        if ((v1o = eeval (co, TCgetnext (co, i1))) == NULL) {
 
231
            err (ERRNORHS, ERR4, co, TCgetnext (co, i1));
 
232
            return NULL;
 
233
        }
 
234
        m1 = Mpushmark (v1o);
 
235
        res = getvar (co, i1, &tnk);
 
236
        Mpopmark (m1);
 
237
        if (res == -1) {
 
238
            err (ERRNOLHS, ERR3, co, i1);
 
239
            return NULL;
 
240
        }
 
241
        setvar (tnk, v1o);
 
242
        return v1o;
 
243
    case C_OR:
 
244
    case C_AND:
 
245
    case C_NOT:
 
246
        i1 = TCgetfp (co, ci);
 
247
        if ((v1o = eeval (co, i1)) == NULL)
 
248
            err (ERRNORHS, ERR4, co, i1);
 
249
        switch (ctype) {
 
250
        case C_OR:
 
251
            if (boolop (v1o) == TRUE)
 
252
                return Ttrue;
 
253
            if ((v1o = eeval (co, TCgetnext (co, i1))) == NULL)
 
254
                err (ERRNORHS, ERR4, co, TCgetnext (co, i1));
 
255
            return (boolop (v1o) == TRUE) ? Ttrue: Tfalse;
 
256
        case C_AND:
 
257
            if (boolop (v1o) == FALSE)
 
258
                return Tfalse;
 
259
            if ((v1o = eeval (co, TCgetnext (co, i1))) == NULL)
 
260
                err (ERRNORHS, ERR4, co, TCgetnext (co, i1));
 
261
            return (boolop (v1o) == FALSE) ? Tfalse: Ttrue;
 
262
        case C_NOT:
 
263
            return (boolop (v1o) == TRUE) ? Tfalse: Ttrue;
 
264
        }
 
265
        /* NOT REACHED */
 
266
        return Tfalse;
 
267
    case C_EQ:
 
268
    case C_NE:
 
269
    case C_LT:
 
270
    case C_LE:
 
271
    case C_GT:
 
272
    case C_GE:
 
273
        i1 = TCgetfp (co, ci);
 
274
        if ((v1o = eeval (co, i1)) == NULL)
 
275
            err (ERRNORHS, ERR4, co, i1);
 
276
        else
 
277
            m1 = Mpushmark (v1o);
 
278
        if ((v2o = eeval (co, TCgetnext (co, i1))) == NULL)
 
279
            err (ERRNORHS, ERR4, co, TCgetnext (co, i1));
 
280
        if (v1o)
 
281
            Mpopmark (m1);
 
282
        return (orderop (v1o, ctype, v2o) == TRUE) ? Ttrue: Tfalse;
 
283
    case C_PLUS:
 
284
    case C_MINUS:
 
285
    case C_MUL:
 
286
    case C_DIV:
 
287
    case C_MOD:
 
288
    case C_UMINUS:
 
289
        i1 = TCgetfp (co, ci);
 
290
        if ((lnum.type = TCgettype (co, i1)) == C_INTEGER)
 
291
            lnum.u.i = TCgetinteger (co, i1);
 
292
        else if (lnum.type == C_REAL)
 
293
            lnum.u.d = TCgetreal (co, i1);
 
294
        else if ((lnum.u.no = eeval (co, i1)) == NULL) {
 
295
            err (ERRNORHS, ERR4, co, i1);
 
296
            return NULL;
 
297
        }
 
298
        if (ctype == C_UMINUS) {
 
299
            if (!(v1o = arithop (&lnum, ctype, NULL)))
 
300
                err (ERRNORHS, ERR4, co, ci);
 
301
            return v1o;
 
302
        }
 
303
        if (lnum.type != C_INTEGER && lnum.type != C_REAL)
 
304
            m1 = Mpushmark (lnum.u.no);
 
305
        i1 = TCgetnext (co, i1);
 
306
        if ((rnum.type = TCgettype (co, i1)) == C_INTEGER)
 
307
            rnum.u.i = TCgetinteger (co, i1);
 
308
        else if (rnum.type == C_REAL)
 
309
            rnum.u.d = TCgetreal (co, i1);
 
310
        else if ((rnum.u.no = eeval (co, i1)) == NULL)
 
311
            err (ERRNORHS, ERR4, co, i1);
 
312
        if (lnum.type != C_INTEGER && lnum.type != C_REAL)
 
313
            Mpopmark (m1);
 
314
        if (!(v1o = arithop (&lnum, ctype, &rnum)))
 
315
            err (ERRNORHS, ERR4, co, ci);
 
316
        return v1o;
 
317
    case C_PEXPR:
 
318
        ci = TCgetfp (co, ci);
 
319
        goto tailrec;
 
320
    case C_FCALL:
 
321
        return efcall (co, ci);
 
322
    case C_INTEGER:
 
323
        return Tinteger (TCgetinteger (co, ci));
 
324
    case C_REAL:
 
325
        return Treal (TCgetreal (co, ci));
 
326
    case C_STRING:
 
327
        return Tstring (TCgetstring (co, ci));
 
328
    case C_GVAR:
 
329
    case C_LVAR:
 
330
    case C_PVAR:
 
331
        return getval (co, ci);
 
332
    case C_FUNCTION:
 
333
        return Tcode (TCgetaddr (co, ci), ci,
 
334
                (int) TCgetinteger (co, TCgetfp (co, ci)));
 
335
    case C_TCONS:
 
336
        v1o = Ttable (0);
 
337
        m1 = Mpushmark (v1o);
 
338
        for (i1 = TCgetfp (co, ci); i1 != C_NULL;
 
339
                i1 = TCgetnext (co, TCgetnext (co, i1))) {
 
340
            if (!(v3o = eeval (co, TCgetnext (co, i1)))) {
 
341
                err (ERRNORHS, ERR4, co, TCgetnext (co, i1));
 
342
                continue;
 
343
            }
 
344
            m2 = Mpushmark (v3o);
 
345
            if (!(v2o = eeval (co, i1))) {
 
346
                err (ERRNOLHS, ERR3, co, i1);
 
347
                Mpopmark (m2);
 
348
                continue;
 
349
            }
 
350
            ttype = Tgettype (v2o);
 
351
            if (ttype == T_INTEGER || ttype == T_REAL || ttype == T_STRING)
 
352
                Tinso (v1o, v2o, v3o);
 
353
            else
 
354
                err (ERRNOLHS, ERR1, co, i1);
 
355
        }
 
356
        Mpopmark (m1);
 
357
        return v1o;
 
358
    case C_STMT:
 
359
        for (i1 = TCgetfp (co, ci); i1 != C_NULL; )
 
360
            if ((i2 = TCgetnext (co, i1)) != C_NULL) {
 
361
                eeval (co, i1);
 
362
                i1 = i2;
 
363
            } else {
 
364
                ci = i1;
 
365
                goto tailrec;
 
366
            }
 
367
        /* NOT REACHED */
 
368
        break;
 
369
    case C_IF:
 
370
        i1 = TCgetfp (co, ci);
 
371
        if (!(v1o = eeval (co, i1)))
 
372
            err (ERRNORHS, ERR5, co, i1);
 
373
        if (boolop (v1o) == TRUE) {
 
374
            ci = TCgetnext (co, i1);
 
375
            goto tailrec;
 
376
        } else if ((ci = TCgetnext (co, TCgetnext (co, i1))) != C_NULL)
 
377
            goto tailrec;
 
378
        break;
 
379
    case C_WHILE:
 
380
        ewhilest (co, ci);
 
381
        break;
 
382
    case C_FOR:
 
383
        eforst (co, ci);
 
384
        break;
 
385
    case C_FORIN:
 
386
        eforinst (co, ci);
 
387
        break;
 
388
    case C_BREAK:
 
389
        pljtype = PLJ_BREAK;
 
390
        longjmp (*pljbufp1, 1);
 
391
        /* NOT REACHED */
 
392
        break;
 
393
    case C_CONTINUE:
 
394
        pljtype = PLJ_CONTINUE;
 
395
        longjmp (*pljbufp1, 1);
 
396
        /* NOT REACHED */
 
397
        break;
 
398
    case C_RETURN:
 
399
        if ((i1 = TCgetfp (co, ci)) != C_NULL)
 
400
            rtno = eeval (co, i1);
 
401
        pljtype = PLJ_RETURN;
 
402
        longjmp (*pljbufp2, 1);
 
403
        /* NOT REACHED */
 
404
        break;
 
405
    default:
 
406
        panic (POS, "eeval", "unknown program token type %d", ctype);
 
407
    }
 
408
    return v1o;
 
409
}
 
410
 
 
411
static Tobj efcall (Tobj co, int ci) {
 
412
    volatile jmp_buf *opljbufp1, *opljbufp2;
 
413
    volatile long m;
 
414
    volatile int bi, ownsinfoi, li, ln;
 
415
 
 
416
    jmp_buf pljbuf;
 
417
    Tobj fdo, vo, lrtno;
 
418
    int i, fci, ai, di, di1, fid;
 
419
 
 
420
    ownsinfoi = sinfoi++;
 
421
    if (sinfoi == sinfon) {
 
422
        sinfop = Marraygrow (sinfop, (long) (sinfon + SINFOINCR) * SINFOSIZE);
 
423
        sinfon += SINFOINCR;
 
424
    }
 
425
    sinfop[ownsinfoi].co = co;
 
426
    sinfop[ownsinfoi].ci = ci;
 
427
    sinfop[ownsinfoi].fco = NULL;
 
428
    sinfop[ownsinfoi].flvari = flvari;
 
429
    sinfop[ownsinfoi].llvari = llvari;
 
430
    fci = TCgetfp (co, ci);
 
431
    if (!(fdo = getval (co, fci)) || Tgettype (fdo) != T_CODE) {
 
432
        err (ERRNOSUCHFUNC, ERR2, co, fci);
 
433
        sinfoi = ownsinfoi;
 
434
        return NULL;
 
435
    }
 
436
 
 
437
    m = Mpushmark ((Tobj) fdo);
 
438
    ai = TCgetfp (co, TCgetnext (co, fci));
 
439
    ln = (int) TCgetinteger (fdo, (li = TCgetnext (fdo, TCgetfp (fdo, 0))));
 
440
    di = TCgetnext (fdo, li);
 
441
    bi = TCgetnext (fdo, di);
 
442
    if (bi != C_NULL && TCgettype (fdo, bi) == C_INTERNAL) {
 
443
        for (i = 0; ai != C_NULL; ai = TCgetnext (co, ai), i++) {
 
444
            if (!(vo = eeval (co, ai))) {
 
445
                err (ERRBADARG, ERR2, co, ai);
 
446
                Mpopmark (m);
 
447
                llvari = sinfop[ownsinfoi].llvari;
 
448
                sinfoi = ownsinfoi;
 
449
                return NULL;
 
450
            }
 
451
            if (llvari + 1 > lvarn) {
 
452
                lvarp = Marraygrow (lvarp, (long) (llvari + 1) * LVARSIZE);
 
453
                lvarn = llvari + 1;
 
454
            }
 
455
            lvarp[llvari].m = Mpushmark ((lvarp[llvari].o = vo));
 
456
            llvari++;
 
457
        }
 
458
        fid = (int) TCgetinteger (fdo, TCgetfp (fdo, bi));
 
459
        if (Ifuncs[fid].min > i || Ifuncs[fid].max < i) {
 
460
            err (ERRARGMIS, ERR2, co, ci);
 
461
            Mpopmark (m);
 
462
            llvari = sinfop[ownsinfoi].llvari;
 
463
            sinfoi = ownsinfoi;
 
464
            return NULL;
 
465
        }
 
466
        flvari = sinfop[ownsinfoi].llvari;
 
467
        sinfop[ownsinfoi].fco = fdo;
 
468
        sinfop[ownsinfoi].fci = bi;
 
469
        if (fid < 0 || fid >= Ifuncn)
 
470
            panic (POS, "efcall", "no such internal function: %d", fid);
 
471
        rtno = Ttrue;
 
472
        if ((*Ifuncs[fid].func) (i, &lvarp[flvari]) == L_FAILURE) {
 
473
            rtno = NULL;
 
474
            err (ERRIFUNCERR, ERR2, co, ci);
 
475
        }
 
476
    } else {
 
477
        if (llvari + ln > lvarn) {
 
478
            lvarp = Marraygrow (lvarp, (long) (llvari + ln) * LVARSIZE);
 
479
            lvarn = llvari + ln;
 
480
        }
 
481
        di1 = TCgetfp (fdo, di);
 
482
        for (i = 0; i < ln && di1 != C_NULL && ai != C_NULL;
 
483
                i++, ai = TCgetnext (co, ai)) {
 
484
            if (!(vo = eeval (co, ai))) {
 
485
                err (ERRBADARG, ERR2, co, ai);
 
486
                Mpopmark (m);
 
487
                llvari = sinfop[ownsinfoi].llvari;
 
488
                sinfoi = ownsinfoi;
 
489
                return NULL;
 
490
            }
 
491
            lvarp[llvari].m = Mpushmark ((lvarp[llvari].o = vo));
 
492
            llvari++;
 
493
            di1 = TCgetnext (fdo, di1);
 
494
        }
 
495
        if (di1 != C_NULL || ai != C_NULL) {
 
496
            err (ERRARGMIS, ERR2, co, ci);
 
497
            Mpopmark (m);
 
498
            llvari = sinfop[ownsinfoi].llvari;
 
499
            sinfoi = ownsinfoi;
 
500
            return NULL;
 
501
        }
 
502
        for (; i < ln; i++, llvari++)
 
503
            lvarp[llvari].m = Mpushmark ((lvarp[llvari].o = NULL));
 
504
        flvari = sinfop[ownsinfoi].llvari;
 
505
        PUSHJMP (opljbufp2, pljbufp2, pljbuf);
 
506
        opljbufp1 = (volatile jmp_buf *) pljbufp1;
 
507
        if (setjmp (*pljbufp2)) {
 
508
            ;
 
509
        } else {
 
510
            sinfop[ownsinfoi].fco = fdo;
 
511
            for (; bi != C_NULL; bi = TCgetnext (fdo, bi)) {
 
512
                sinfop[ownsinfoi].fci = bi;
 
513
                if (TCgettype (fdo, bi) != C_DECL)
 
514
                    eeval ((Tobj) fdo, bi);
 
515
            }
 
516
        }
 
517
        POPJMP (opljbufp2, pljbufp2);
 
518
        pljbufp1 = (jmp_buf *) opljbufp1;
 
519
    }
 
520
    flvari = sinfop[ownsinfoi].flvari;
 
521
    llvari = sinfop[ownsinfoi].llvari;
 
522
    sinfoi = ownsinfoi;
 
523
    Mpopmark (m);
 
524
    lrtno = rtno, rtno = NULL;
 
525
    errdo = TRUE;
 
526
    return lrtno;
 
527
}
 
528
 
 
529
static void ewhilest (Tobj co, int ci) {
 
530
    volatile jmp_buf *opljbufp;
 
531
    volatile jmp_buf pljbuf;
 
532
    volatile Tobj c1o;
 
533
    volatile int ei, si;
 
534
 
 
535
    Tobj v1o;
 
536
 
 
537
    c1o = (volatile Tobj) co; /* protect argument from longjmp */
 
538
    ei = TCgetfp (c1o, ci);
 
539
    si = TCgetnext (c1o, ei);
 
540
    PUSHJMP (opljbufp, pljbufp1, pljbuf);
 
541
    for (;;) {
 
542
        if (!(v1o = eeval ((Tobj) c1o, ei)))
 
543
            err (ERRNORHS, ERR5, c1o, ei);
 
544
        if (boolop (v1o) == FALSE)
 
545
            break;
 
546
        if (setjmp (*pljbufp1)) {
 
547
            if (pljtype == PLJ_CONTINUE)
 
548
                continue;
 
549
            else if (pljtype == PLJ_BREAK)
 
550
                break;
 
551
        }
 
552
        eeval ((Tobj) c1o, si);
 
553
    }
 
554
    POPJMP (opljbufp, pljbufp1);
 
555
}
 
556
 
 
557
static void eforst (Tobj co, int ci) {
 
558
    volatile jmp_buf *opljbufp;
 
559
    volatile jmp_buf pljbuf;
 
560
    volatile Tobj c1o;
 
561
    volatile int ei1, ei2, ei3, si, eisnop1, eisnop2, eisnop3;
 
562
 
 
563
    Tobj v1o;
 
564
 
 
565
    c1o = (volatile Tobj) co; /* protect argument from longjmp */
 
566
    ei1 = TCgetfp (c1o, ci);
 
567
    ei2 = TCgetnext (c1o, ei1);
 
568
    ei3 = TCgetnext (c1o, ei2);
 
569
    si = TCgetnext (c1o, ei3);
 
570
    eisnop1 = (TCgettype (c1o, ei1) == C_NOP);
 
571
    eisnop2 = (TCgettype (c1o, ei2) == C_NOP);
 
572
    eisnop3 = (TCgettype (c1o, ei3) == C_NOP);
 
573
    PUSHJMP (opljbufp, pljbufp1, pljbuf);
 
574
    if (!eisnop1)
 
575
        eeval ((Tobj) c1o, ei1);
 
576
    for (;;) {
 
577
        if (!eisnop2) {
 
578
            if (!(v1o = eeval ((Tobj) c1o, ei2)))
 
579
                err (ERRNORHS, ERR5, c1o, ei2);
 
580
            if (boolop (v1o) == FALSE)
 
581
                break;
 
582
        }
 
583
        if (setjmp (*pljbufp1) != 0) {
 
584
            if (pljtype == PLJ_CONTINUE)
 
585
                ;
 
586
            else if (pljtype == PLJ_BREAK)
 
587
                break;
 
588
        } else {
 
589
            eeval ((Tobj) c1o, si);
 
590
        }
 
591
        if (!eisnop3)
 
592
            eeval ((Tobj) c1o, ei3);
 
593
    }
 
594
    POPJMP (opljbufp, pljbufp1);
 
595
}
 
596
 
 
597
static void eforinst (Tobj co, int ci) {
 
598
    volatile jmp_buf *opljbufp;
 
599
    volatile jmp_buf pljbuf;
 
600
    volatile Tobj tblo, c1o;
 
601
    volatile Tkvindex_t tkvi;
 
602
    volatile tnk_t tnk;
 
603
    volatile long km, t;
 
604
    volatile int ei1, ei2, si;
 
605
 
 
606
    c1o = (volatile Tobj) co; /* protect argument from longjmp */
 
607
    ei1 = TCgetfp (c1o, ci);
 
608
    ei2 = TCgetnext (c1o, ei1);
 
609
    si = TCgetnext (c1o, ei2);
 
610
    if (getvar ((Tobj) c1o, ei1, (tnk_t *) &tnk) == -1) {
 
611
        err (ERRNOLHS, ERR3, c1o, ei1);
 
612
        return;
 
613
    }
 
614
    if (tnk.type == TNK_O)
 
615
        km = Mpushmark (tnk.u.tnko.ko);
 
616
    if (!(tblo = (volatile Tobj) eeval ((Tobj) c1o, ei2))) {
 
617
        if (tnk.type == TNK_O)
 
618
            Mpopmark (km);
 
619
        err (ERRNORHS, ERR4, c1o, ei2);
 
620
        return;
 
621
    }
 
622
    if (Tgettype (tblo) != T_TABLE) {
 
623
        err (ERRNOTATABLE, ERR1, c1o, ei2);
 
624
        return;
 
625
    }
 
626
    PUSHJMP (opljbufp, pljbufp1, pljbuf);
 
627
    t = Tgettime (tblo);
 
628
    for (Tgetfirst ((Tobj) tblo, (Tkvindex_t *) &tkvi); tkvi.kvp;
 
629
            Tgetnext ((Tkvindex_t *) &tkvi)) {
 
630
        setvar (tnk, tkvi.kvp->ko);
 
631
        if (setjmp (*pljbufp1) != 0) {
 
632
            if (pljtype == PLJ_CONTINUE)
 
633
                continue;
 
634
            else if (pljtype == PLJ_BREAK)
 
635
                break;
 
636
        }
 
637
        eeval ((Tobj) c1o, si);
 
638
        if (t != Tgettime (tblo)) {
 
639
            err (ERRTABLECHANGED, ERR1, c1o, ei2);
 
640
            break;
 
641
        }
 
642
    }
 
643
    POPJMP (opljbufp, pljbufp1);
 
644
    if (tnk.type == TNK_O)
 
645
        Mpopmark (km);
 
646
}
 
647
 
 
648
static Tobj getval (Tobj co, int ci) {
 
649
    Tobj cvo, cko, cto;
 
650
    Ctype_t ct, vt;
 
651
    int vi, ni, nn;
 
652
 
 
653
    if ((ct = TCgettype (co, ci)) == C_LVAR) {
 
654
        nn = (int) TCgetinteger (co, (ni = TCgetnext (co, TCgetfp (co, ci))));
 
655
        cto = cvo = lvarp[flvari + nn].o;
 
656
        if (!cto)
 
657
            return NULL;
 
658
        vi = TCgetnext (co, ni);
 
659
    } else if (ct == C_GVAR) {
 
660
        cto = root;
 
661
        vi = TCgetfp (co, ci);
 
662
    } else if (ct == C_PVAR)
 
663
        return TCgetobject (co, ci);
 
664
    else
 
665
        return NULL;
 
666
 
 
667
    while (vi != C_NULL) {
 
668
        if (Tgettype (cto) != T_TABLE)
 
669
            return NULL;
 
670
        if ((vt = TCgettype (co, vi)) == C_STRING) {
 
671
            if (!(cvo = Tfinds (cto, TCgetstring (co, vi))))
 
672
                return NULL;
 
673
        } else if (vt == C_INTEGER) {
 
674
            if (!(cvo = Tfindi (cto, TCgetinteger (co, vi))))
 
675
                return NULL;
 
676
        } else if (vt == C_REAL) {
 
677
            if (!(cvo = Tfindr (cto, TCgetreal (co, vi))))
 
678
                return NULL;
 
679
        } else {
 
680
            if (!(cko = eeval (co, vi)) || !(cvo = Tfindo (cto, cko)))
 
681
                return NULL;
 
682
        }
 
683
        cto = cvo;
 
684
        vi = TCgetnext (co, vi);
 
685
    }
 
686
    return cvo;
 
687
}
 
688
 
 
689
static int getvar (Tobj co, int ci, tnk_t *tnkp) {
 
690
    Tobj cvo, cko, cto;
 
691
    Ctype_t ct, vt;
 
692
    long m;
 
693
    int vi, ovi, nn, ni;
 
694
 
 
695
    if ((ct = TCgettype (co, ci)) == C_LVAR) {
 
696
        nn = (int) TCgetinteger (co, (ni = TCgetnext (co, TCgetfp (co, ci))));
 
697
        cvo = cto = lvarp[flvari + nn].o;
 
698
        vi = TCgetnext (co, ni);
 
699
        if (vi != C_NULL && (!cvo || Tgettype (cvo) != T_TABLE))
 
700
            Mresetmark (lvarp[flvari + nn].m,
 
701
                    (lvarp[flvari + nn].o = cvo = cto = Ttable (0)));
 
702
    } else if (ct == C_GVAR) { /* else it's a global variable */
 
703
        cvo = root;
 
704
        vi = TCgetfp (co, ci);
 
705
    } else {
 
706
        return -1;
 
707
    }
 
708
 
 
709
    ovi = -1;
 
710
    while (vi != C_NULL) {
 
711
        cto = cvo;
 
712
        if ((vt = TCgettype (co, vi)) == C_STRING) {
 
713
            cvo = Tfinds (cto, TCgetstring (co, vi));
 
714
        } else if (vt == C_INTEGER) {
 
715
            cvo = Tfindi (cto, TCgetinteger (co, vi));
 
716
        } else if (vt == C_REAL) {
 
717
            cvo = Tfindr (cto, TCgetreal (co, vi));
 
718
        } else {
 
719
            if (!(cko = eeval (co, vi)) || !(T_ISSTRING (cko) ||
 
720
                    T_ISNUMBER (cko)))
 
721
                return -1;
 
722
            cvo = Tfindo (cto, cko);
 
723
        }
 
724
        ovi = vi, vi = TCgetnext (co, vi);
 
725
        if (vi != C_NULL && (!cvo || Tgettype (cvo) != T_TABLE)) {
 
726
            if (vt == C_STRING)
 
727
                Tinss (cto, TCgetstring (co, ovi), (cvo = Ttable (0)));
 
728
            else if (vt == C_INTEGER)
 
729
                Tinsi (cto, TCgetinteger (co, ovi), (cvo = Ttable (0)));
 
730
            else if (vt == C_REAL)
 
731
                Tinsr (cto, TCgetreal (co, ovi), (cvo = Ttable (0)));
 
732
            else
 
733
                m = Mpushmark (cko), Tinso (cto, cko, (cvo = Ttable (0))),
 
734
                        Mpopmark (m);
 
735
        }
 
736
    }
 
737
    if (ct == C_LVAR && ovi == -1) {
 
738
        tnkp->type = TNK_LI;
 
739
        tnkp->u.li = nn;
 
740
    } else {
 
741
        switch (vt) {
 
742
        case C_STRING:
 
743
        case C_INTEGER:
 
744
        case C_REAL:
 
745
            tnkp->type = TNK_S;
 
746
            tnkp->u.tnks.kt = vt;
 
747
            tnkp->u.tnks.to = cto;
 
748
            tnkp->u.tnks.co = co;
 
749
            tnkp->u.tnks.vi = ovi;
 
750
            break;
 
751
        default:
 
752
            tnkp->type = TNK_O;
 
753
            tnkp->u.tnko.to = cto;
 
754
            tnkp->u.tnko.ko = cko;
 
755
            break;
 
756
        }
 
757
    }
 
758
    return 0;
 
759
}
 
760
 
 
761
static void setvar (tnk_t tnk, Tobj vo) {
 
762
    switch (tnk.type) {
 
763
    case TNK_LI:
 
764
        Mresetmark (lvarp[flvari + tnk.u.li].m,
 
765
                (lvarp[flvari + tnk.u.li].o = vo));
 
766
        break;
 
767
    case TNK_O:
 
768
        Tinso (tnk.u.tnko.to, tnk.u.tnko.ko, vo);
 
769
        break;
 
770
    default:
 
771
        switch (tnk.u.tnks.kt) {
 
772
        case C_STRING:
 
773
            Tinss (tnk.u.tnks.to,
 
774
                    TCgetstring (tnk.u.tnks.co, tnk.u.tnks.vi), vo);
 
775
            break;
 
776
        case C_INTEGER:
 
777
            Tinsi (tnk.u.tnks.to,
 
778
                    TCgetinteger (tnk.u.tnks.co, tnk.u.tnks.vi), vo);
 
779
            break;
 
780
        case C_REAL:
 
781
            Tinsr (tnk.u.tnks.to, TCgetreal (tnk.u.tnks.co, tnk.u.tnks.vi), vo);
 
782
            break;
 
783
        }
 
784
        break;
 
785
    }
 
786
}
 
787
 
 
788
static int boolop (Tobj vo) {
 
789
    long i;
 
790
    double d;
 
791
 
 
792
    if (!vo)
 
793
        return FALSE;
 
794
 
 
795
    switch (Tgettype (vo)) {
 
796
    case T_INTEGER:
 
797
        i = Tgetinteger (vo);
 
798
        return (i == 0) ? FALSE : TRUE;
 
799
    case T_REAL:
 
800
        d = Tgetreal (vo);
 
801
        return (d == 0.0) ? FALSE : TRUE;
 
802
    case T_TABLE:
 
803
        if (vo == null)
 
804
            return FALSE;
 
805
        return TRUE;
 
806
    default:
 
807
        return TRUE;
 
808
    }
 
809
}
 
810
 
 
811
static int orderop (Tobj v1o, Ctype_t op, Tobj v2o) {
 
812
    Ctype_t t1, t2;
 
813
    long i1, i2;
 
814
    int r;
 
815
    double d1, d2;
 
816
 
 
817
    if (!v1o || !v2o) {
 
818
        if ((v1o || v2o) && op == C_NE)
 
819
            return TRUE;
 
820
        return FALSE;
 
821
    }
 
822
    t1 = Tgettype (v1o), t2 = Tgettype (v2o);
 
823
    if (t1 == T_STRING && t2 == T_STRING) {
 
824
        r = Strcmp (Tgetstring (v1o), Tgetstring (v2o));
 
825
    } else if (t1 == T_INTEGER && t2 == T_INTEGER) {
 
826
        i1 = Tgetinteger (v1o), i2 = Tgetinteger (v2o);
 
827
        r = (i1 == i2) ? 0 : ((i1 < i2) ? -1 : 1);
 
828
    } else if (t1 == T_INTEGER && t2 == T_REAL) {
 
829
        i1 = Tgetinteger (v1o), d2 = Tgetreal (v2o);
 
830
        r = (i1 == d2) ? 0 : ((i1 < d2) ? -1 : 1);
 
831
    } else if (t1 == T_REAL && t2 == T_INTEGER) {
 
832
        d1 = Tgetreal (v1o), i2 = Tgetinteger (v2o);
 
833
        r = (d1 == i2) ? 0 : ((d1 < i2) ? -1 : 1);
 
834
    } else if (t1 == T_REAL && t2 == T_REAL) {
 
835
        d1 = Tgetreal (v1o), d2 = Tgetreal (v2o);
 
836
        r = (d1 == d2) ? 0 : ((d1 < d2) ? -1 : 1);
 
837
    } else if (t1 == t2) {
 
838
        if (op != C_EQ && op != C_NE)
 
839
            return FALSE;
 
840
        r = (v1o == v2o) ? 0 : 1;
 
841
    } else {
 
842
        return FALSE;
 
843
    }
 
844
    switch (op) {
 
845
    case C_EQ: return (r == 0) ? TRUE : FALSE;
 
846
    case C_NE: return (r != 0) ? TRUE : FALSE;
 
847
    case C_LT: return (r <  0) ? TRUE : FALSE;
 
848
    case C_LE: return (r <= 0) ? TRUE : FALSE;
 
849
    case C_GT: return (r >  0) ? TRUE : FALSE;
 
850
    case C_GE: return (r >= 0) ? TRUE : FALSE;
 
851
    }
 
852
    panic (POS, "orderop", "bad op code");
 
853
    return FALSE; /* NOT REACHED */
 
854
}
 
855
 
 
856
static Tobj arithop (Num_t *lnum, Ctype_t op, Num_t *rnum) {
 
857
    double d1, d2, d3;
 
858
 
 
859
    if (!rnum && op != C_UMINUS)
 
860
        return NULL;
 
861
    if (lnum->type == C_INTEGER)
 
862
        d1 = lnum->u.i;
 
863
    else if (lnum->type == C_REAL)
 
864
        d1 = lnum->u.d;
 
865
    else if (!lnum->u.no)
 
866
        return NULL;
 
867
    else if (Tgettype (lnum->u.no) == T_INTEGER)
 
868
        d1 = Tgetinteger (lnum->u.no);
 
869
    else if (Tgettype (lnum->u.no) == T_REAL)
 
870
        d1 = Tgetreal (lnum->u.no);
 
871
    else
 
872
        return NULL;
 
873
    if (op == C_UMINUS) {
 
874
        d3 = -d1;
 
875
        goto result;
 
876
    }
 
877
    if (rnum->type == C_INTEGER)
 
878
        d2 = rnum->u.i;
 
879
    else if (rnum->type == C_REAL)
 
880
        d2 = rnum->u.d;
 
881
    else if (!rnum->u.no)
 
882
        return NULL;
 
883
    else if (Tgettype (rnum->u.no) == T_INTEGER)
 
884
        d2 = Tgetinteger (rnum->u.no);
 
885
    else if (Tgettype (rnum->u.no) == T_REAL)
 
886
        d2 = Tgetreal (rnum->u.no);
 
887
    else
 
888
        return NULL;
 
889
    switch (op) {
 
890
    case C_PLUS:  d3 = d1 + d2;               break;
 
891
    case C_MINUS: d3 = d1 - d2;               break;
 
892
    case C_MUL:   d3 = d1 * d2;               break;
 
893
    case C_DIV:   d3 = d1 / d2;               break;
 
894
    case C_MOD:   d3 = (long) d1 % (long) d2; break;
 
895
    }
 
896
result:
 
897
    if (d3 == (double) (long) d3)
 
898
        return Tinteger ((long) d3);
 
899
    return Treal (d3);
 
900
}
 
901
 
 
902
static void err (int errnum, int level, Tobj co, int ci) {
 
903
    char *s;
 
904
    int si, i;
 
905
 
 
906
    if (level > Eerrlevel || !errdo)
 
907
        return;
 
908
    s = "";
 
909
    fprintf (stderr, "runtime error: %s\n", errnam[errnum]);
 
910
    if (!co)
 
911
        return;
 
912
    if (Estackdepth < 1)
 
913
        return;
 
914
    if (!sinfop[(si = sinfoi - 1)].fco && si > 0)
 
915
        si--;
 
916
    if (Eshowbody > 0) {
 
917
        if (co == sinfop[si].fco)
 
918
            s = Scfull (co, 0, ci);
 
919
        else if (co == sinfop[si].co)
 
920
            s = Scfull (co, TCgetfp (co, 0), ci);
 
921
        printbody (s, Eshowbody), free (s);
 
922
        if (Estackdepth == 1) {
 
923
            fprintf (stderr, "\n");
 
924
            errdo = FALSE;
 
925
        }
 
926
        for (i = si; i >= 0; i--) {
 
927
            if (sinfop[i].fco) {
 
928
                s = Scfull (sinfop[i].fco, 0, sinfop[i].fci);
 
929
                printbody (s, Eshowbody), free (s);
 
930
            }
 
931
        }
 
932
        s = Scfull (sinfop[0].co, TCgetfp (sinfop[0].co, 0), sinfop[0].ci);
 
933
        printbody (s, Eshowbody), free (s);
 
934
    }
 
935
    fprintf (stderr, "\n");
 
936
    errdo = FALSE;
 
937
}
 
938
 
 
939
static void printbody (char *s, int mode) {
 
940
    char *s1, *s2;
 
941
    char c;
 
942
 
 
943
    if (mode == 2) {
 
944
        fprintf (stderr, "%s\n", s);
 
945
        return;
 
946
    }
 
947
    c = '\000';
 
948
    for (s1 = s; *s1; s1++)
 
949
        if (*s1 == '>' && *(s1 + 1) && *(s1 + 1) == '>')
 
950
            break;
 
951
    if (!*s1)
 
952
        return;
 
953
    for (; s1 != s; s1--)
 
954
        if (*(s1 - 1) == '\n')
 
955
            break;
 
956
    for (s2 = s1; *s2; s2++)
 
957
        if (*s2 == '\n')
 
958
            break;
 
959
    if (*s2)
 
960
        c = *s2, *s2 = '\000';
 
961
    fprintf (stderr, "%s\n", s1);
 
962
    if (c)
 
963
        *s2 = c;
 
964
}