1 /*
2 * This file is part of DGD, https://github.com/dworkin/dgd
3 * Copyright (C) 1993-2010 Dworkin B.V.
4 * Copyright (C) 2010-2014 DGD Authors (see the commit log for details)
5 *
6 * This program is free software: you can redistribute it and/or modify
7 * it under the terms of the GNU Affero General Public License as
8 * published by the Free Software Foundation, either version 3 of the
9 * License, or (at your option) any later version.
10 *
11 * This program is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 * GNU Affero General Public License for more details.
15 *
16 * You should have received a copy of the GNU Affero General Public License
17 * along with this program. If not, see <http://www.gnu.org/licenses/>.
18 */
19
20 # include "dgd.h"
21 # include "str.h"
22 # include "array.h"
23 # include "object.h"
24 # include "xfloat.h"
25 # include "interpret.h"
26 # include "data.h"
27 # include "control.h"
28 # include "csupport.h"
29 # include "table.h"
30
31 # ifdef DEBUG
32 # undef EXTRA_STACK
33 # define EXTRA_STACK 0
34 # endif
35
36 typedef struct _inhash_ {
37 Uint ocount; /* object count */
38 uindex iindex; /* inherit index */
39 uindex coindex; /* class name program reference */
40 Uint class; /* class name string reference */
41 } inhash;
42
43 static value stack[MIN_STACK]; /* initial stack */
44 static frame topframe; /* top frame */
45 static rlinfo rlim; /* top rlimits info */
46 frame *cframe; /* current frame */
47 static char *creator; /* creator function name */
48 static unsigned int clen; /* creator function name length */
49 static bool stricttc; /* strict typechecking */
50 static inhash ihash[INHASHSZ]; /* instanceof hashtable */
51
52 int nil_type; /* type of nil value */
53 value zero_int = { T_INT, TRUE };
54 value zero_float = { T_FLOAT, TRUE };
55 value nil_value = { T_NIL, TRUE };
56
57 /*
58 * NAME: interpret->init()
59 * DESCRIPTION: initialize the interpreter
60 */
i_init(char * create,int flag)61 void i_init(char *create, int flag)
62 {
63 topframe.oindex = OBJ_NONE;
64 topframe.fp = topframe.sp = stack + MIN_STACK;
65 topframe.stack = topframe.lip = stack;
66 rlim.maxdepth = 0;
67 rlim.ticks = 0;
68 rlim.nodepth = TRUE;
69 rlim.noticks = TRUE;
70 topframe.rlim = &rlim;
71 topframe.level = 0;
72 topframe.atomic = FALSE;
73 cframe = &topframe;
74
75 creator = create;
76 clen = strlen(create);
77 stricttc = flag;
78
79 nil_value.type = nil_type = (stricttc) ? T_NIL : T_INT;
80 }
81
82 /*
83 * NAME: interpret->ref_value()
84 * DESCRIPTION: reference a value
85 */
i_ref_value(value * v)86 void i_ref_value(value *v)
87 {
88 switch (v->type) {
89 case T_STRING:
90 str_ref(v->u.string);
91 break;
92
93 case T_ARRAY:
94 case T_MAPPING:
95 case T_LWOBJECT:
96 arr_ref(v->u.array);
97 break;
98 }
99 }
100
101 /*
102 * NAME: interpret->del_value()
103 * DESCRIPTION: dereference a value (not an lvalue)
104 */
i_del_value(value * v)105 void i_del_value(value *v)
106 {
107 switch (v->type) {
108 case T_STRING:
109 str_del(v->u.string);
110 break;
111
112 case T_ARRAY:
113 case T_MAPPING:
114 case T_LWOBJECT:
115 arr_del(v->u.array);
116 break;
117 }
118 }
119
120 /*
121 * NAME: interpret->copy()
122 * DESCRIPTION: copy values from one place to another
123 */
i_copy(value * v,value * w,unsigned int len)124 void i_copy(value *v, value *w, unsigned int len)
125 {
126 value *o;
127
128 for ( ; len != 0; --len) {
129 switch (w->type) {
130 case T_STRING:
131 str_ref(w->u.string);
132 break;
133
134 case T_OBJECT:
135 if (DESTRUCTED(w)) {
136 *v++ = nil_value;
137 w++;
138 continue;
139 }
140 break;
141
142 case T_LWOBJECT:
143 o = d_get_elts(w->u.array);
144 if (o->type == T_OBJECT && DESTRUCTED(o)) {
145 *v++ = nil_value;
146 w++;
147 continue;
148 }
149 /* fall through */
150 case T_ARRAY:
151 case T_MAPPING:
152 arr_ref(w->u.array);
153 break;
154 }
155 *v++ = *w++;
156 }
157 }
158
159 /*
160 * NAME: interpret->grow_stack()
161 * DESCRIPTION: check if there is room on the stack for new values; if not,
162 * make space
163 */
i_grow_stack(frame * f,int size)164 void i_grow_stack(frame *f, int size)
165 {
166 if (f->sp < f->lip + size + MIN_STACK) {
167 int spsize, lisize;
168 value *v, *stk;
169 intptr_t offset;
170
171 /*
172 * extend the local stack
173 */
174 spsize = f->fp - f->sp;
175 lisize = f->lip - f->stack;
176 size = ALGN(spsize + lisize + size + MIN_STACK, 8);
177 stk = ALLOC(value, size);
178 offset = (intptr_t) (stk + size) - (intptr_t) f->fp;
179
180 /* move lvalue index stack values */
181 if (lisize != 0) {
182 memcpy(stk, f->stack, lisize * sizeof(value));
183 }
184 f->lip = stk + lisize;
185
186 /* move stack values */
187 v = stk + size;
188 if (spsize != 0) {
189 memcpy(v - spsize, f->sp, spsize * sizeof(value));
190 do {
191 --v;
192 if ((v->type == T_LVALUE || v->type == T_SLVALUE) &&
193 v->u.lval >= f->sp && v->u.lval < f->fp) {
194 v->u.lval = (value *) ((intptr_t) v->u.lval + offset);
195 }
196 } while (--spsize > 0);
197 }
198 f->sp = v;
199
200 /* replace old stack */
201 if (f->sos) {
202 /* stack on stack: alloca'd */
203 AFREE(f->stack);
204 f->sos = FALSE;
205 } else if (f->stack != stack) {
206 FREE(f->stack);
207 }
208 f->stack = stk;
209 f->fp = stk + size;
210 }
211 }
212
213 /*
214 * NAME: interpret->push_value()
215 * DESCRIPTION: push a value on the stack
216 */
i_push_value(frame * f,value * v)217 void i_push_value(frame *f, value *v)
218 {
219 value *o;
220
221 *--f->sp = *v;
222 switch (v->type) {
223 case T_STRING:
224 str_ref(v->u.string);
225 break;
226
227 case T_OBJECT:
228 if (DESTRUCTED(v)) {
229 /*
230 * can't wipe out the original, since it may be a value from a
231 * mapping
232 */
233 *f->sp = nil_value;
234 }
235 break;
236
237 case T_LWOBJECT:
238 o = d_get_elts(v->u.array);
239 if (o->type == T_OBJECT && DESTRUCTED(o)) {
240 /*
241 * can't wipe out the original, since it may be a value from a
242 * mapping
243 */
244 *f->sp = nil_value;
245 break;
246 }
247 /* fall through */
248 case T_ARRAY:
249 case T_MAPPING:
250 arr_ref(v->u.array);
251 break;
252 }
253 }
254
255 /*
256 * NAME: interpret->pop()
257 * DESCRIPTION: pop a number of values (can be lvalues) from the stack
258 */
i_pop(frame * f,int n)259 void i_pop(frame *f, int n)
260 {
261 value *v;
262
263 for (v = f->sp; --n >= 0; v++) {
264 switch (v->type) {
265 case T_STRING:
266 str_del(v->u.string);
267 break;
268
269 case T_LVALUE:
270 if (v->oindex == T_CLASS) {
271 --f->lip;
272 }
273 break;
274
275 case T_ALVALUE:
276 if (v->oindex == T_CLASS) {
277 --f->lip;
278 }
279 --f->lip;
280 case T_ARRAY:
281 case T_MAPPING:
282 case T_LWOBJECT:
283 arr_del(v->u.array);
284 break;
285
286 case T_SLVALUE:
287 if (v->oindex == T_CLASS) {
288 --f->lip;
289 }
290 str_del((--f->lip)->u.string);
291 break;
292
293 case T_MLVALUE:
294 if (v->oindex == T_CLASS) {
295 --f->lip;
296 }
297 i_del_value(--f->lip);
298 arr_del(v->u.array);
299 break;
300
301 case T_SALVALUE:
302 if (v->oindex == T_CLASS) {
303 --f->lip;
304 }
305 str_del((--f->lip)->u.string);
306 --f->lip;
307 arr_del(v->u.array);
308 break;
309
310 case T_SMLVALUE:
311 if (v->oindex == T_CLASS) {
312 --f->lip;
313 }
314 str_del((--f->lip)->u.string);
315 i_del_value(--f->lip);
316 arr_del(v->u.array);
317 break;
318 }
319 }
320 f->sp = v;
321 }
322
323 /*
324 * NAME: interpret->reverse()
325 * DESCRIPTION: reverse the order of arguments on the stack
326 */
i_reverse(frame * f,int n)327 value *i_reverse(frame *f, int n)
328 {
329 if (f->p_ctrl->flags & (CTRL_OLDVM | CTRL_COMPILED)) {
330 value sp[MAX_LOCALS];
331 value lip[3 * MAX_LOCALS];
332 value *v1, *v2, *w1, *w2;
333 value *top;
334
335 top = f->sp + n;
336 if (n > 1) {
337 /*
338 * more than one argument
339 */
340 v1 = f->sp;
341 v2 = sp;
342 w1 = lip;
343 w2 = f->lip;
344 memcpy(v2, v1, n * sizeof(value));
345 v1 += n;
346
347 do {
348 switch (v2->type) {
349 case T_LVALUE:
350 if (v2->oindex == T_CLASS) {
351 *w1++ = *--w2;
352 }
353 break;
354
355 case T_SLVALUE:
356 case T_ALVALUE:
357 case T_MLVALUE:
358 if (v2->oindex == T_CLASS) {
359 w2 -= 2;
360 *w1++ = w2[0];
361 *w1++ = w2[1];
362 } else {
363 *w1++ = *--w2;
364 }
365 break;
366
367 case T_SALVALUE:
368 case T_SMLVALUE:
369 if (v2->oindex == T_CLASS) {
370 w2 -= 3;
371 *w1++ = w2[0];
372 *w1++ = w2[1];
373 *w1++ = w2[2];
374 } else {
375 w2 -= 2;
376 *w1++ = w2[0];
377 *w1++ = w2[1];
378 }
379 break;
380 }
381
382 *--v1 = *v2++;
383 } while (--n != 0);
384
385 /*
386 * copy back lvalue indices, if needed
387 */
388 n = f->lip - w2;
389 if (n > 1) {
390 memcpy(w2, lip, n * sizeof(value));
391 }
392 }
393 return top;
394 } else {
395 value stack[MAX_LOCALS * 6];
396 value *v, *w;
397 int size;
398
399 size = 0;
400 v = f->sp;
401 if (n == 1) {
402 switch (v->u.number >> 28) {
403 case LVAL_LOCAL:
404 case LVAL_GLOBAL:
405 size = 1;
406 break;
407
408 case LVAL_INDEX:
409 case LVAL_LOCAL_INDEX:
410 case LVAL_GLOBAL_INDEX:
411 size = 3;
412 break;
413
414 case LVAL_INDEX_INDEX:
415 size = 5;
416 break;
417 }
418 size += (((v->u.number >> 24) & 0xf) == T_CLASS);
419 v += size;
420 } else if (n > 1) {
421 w = stack + sizeof(stack) / sizeof(value);
422 do {
423 switch (v->u.number >> 28) {
424 case LVAL_LOCAL:
425 case LVAL_GLOBAL:
426 size = 1;
427 break;
428
429 case LVAL_INDEX:
430 case LVAL_LOCAL_INDEX:
431 case LVAL_GLOBAL_INDEX:
432 size = 3;
433 break;
434
435 case LVAL_INDEX_INDEX:
436 size = 5;
437 break;
438 }
439 size += (((v->u.number >> 24) & 0xf) == T_CLASS);
440
441 w -= size;
442 memcpy(w, v, size * sizeof(value));
443 v += size;
444 } while (--n != 0);
445
446 memcpy(f->sp, w, (v - f->sp) * sizeof(value));
447 }
448
449 return v;
450 }
451 }
452
453 /*
454 * NAME: interpret->odest()
455 * DESCRIPTION: replace all occurrences of an object on the stack by nil
456 */
i_odest(frame * prev,object * obj)457 void i_odest(frame *prev, object *obj)
458 {
459 frame *f;
460 Uint count;
461 value *v;
462 unsigned short n;
463
464 count = obj->count;
465
466 /* wipe out objects in stack frames */
467 for (;;) {
468 f = prev;
469 for (v = f->sp; v < f->fp; v++) {
470 switch (v->type) {
471 case T_OBJECT:
472 if (v->u.objcnt == count) {
473 *v = nil_value;
474 }
475 break;
476
477 case T_LWOBJECT:
478 if (v->u.array->elts[0].type == T_OBJECT &&
479 v->u.array->elts[0].u.objcnt == count) {
480 arr_del(v->u.array);
481 *v = nil_value;
482 }
483 break;
484 }
485 }
486 for (v = f->lip; --v >= f->stack; ) {
487 switch (v->type) {
488 case T_OBJECT:
489 if (v->u.objcnt == count) {
490 *v = nil_value;
491 }
492 break;
493
494 case T_LWOBJECT:
495 if (v->u.array->elts[0].type == T_OBJECT &&
496 v->u.array->elts[0].u.objcnt == count) {
497 arr_del(v->u.array);
498 *v = nil_value;
499 }
500 break;
501 }
502 }
503
504 prev = f->prev;
505 if (prev == (frame *) NULL) {
506 break;
507 }
508 if ((f->func->class & C_ATOMIC) && !prev->atomic) {
509 /*
510 * wipe out objects in arguments to atomic function call
511 */
512 for (n = f->nargs, v = prev->sp; n != 0; --n, v++) {
513 switch (v->type) {
514 case T_OBJECT:
515 if (v->u.objcnt == count) {
516 *v = nil_value;
517 }
518 break;
519
520 case T_LWOBJECT:
521 if (v->u.array->elts[0].type == T_OBJECT &&
522 v->u.array->elts[0].u.objcnt == count) {
523 arr_del(v->u.array);
524 *v = nil_value;
525 }
526 break;
527 }
528 }
529 break;
530 }
531 }
532 }
533
534 /*
535 * NAME: interpret->string()
536 * DESCRIPTION: push a string constant on the stack
537 */
i_string(frame * f,int inherit,unsigned int index)538 void i_string(frame *f, int inherit, unsigned int index)
539 {
540 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, inherit, index));
541 }
542
543 /*
544 * NAME: interpret->aggregate()
545 * DESCRIPTION: create an array on the stack
546 */
i_aggregate(frame * f,unsigned int size)547 void i_aggregate(frame *f, unsigned int size)
548 {
549 array *a;
550
551 if (size == 0) {
552 a = arr_new(f->data, 0L);
553 } else {
554 value *v, *elts;
555
556 i_add_ticks(f, size);
557 a = arr_new(f->data, (long) size);
558 elts = a->elts + size;
559 v = f->sp;
560 do {
561 *--elts = *v++;
562 } while (--size != 0);
563 d_ref_imports(a);
564 f->sp = v;
565 }
566 PUSH_ARRVAL(f, a);
567 }
568
569 /*
570 * NAME: interpret->map_aggregate()
571 * DESCRIPTION: create a mapping on the stack
572 */
i_map_aggregate(frame * f,unsigned int size)573 void i_map_aggregate(frame *f, unsigned int size)
574 {
575 array *a;
576
577 if (size == 0) {
578 a = map_new(f->data, 0L);
579 } else {
580 value *v, *elts;
581
582 i_add_ticks(f, size);
583 a = map_new(f->data, (long) size);
584 elts = a->elts + size;
585 v = f->sp;
586 do {
587 *--elts = *v++;
588 } while (--size != 0);
589 f->sp = v;
590 if (ec_push((ec_ftn) NULL)) {
591 /* error in sorting, delete mapping and pass on error */
592 arr_ref(a);
593 arr_del(a);
594 error((char *) NULL);
595 }
596 map_sort(a);
597 ec_pop();
598 d_ref_imports(a);
599 }
600 PUSH_MAPVAL(f, a);
601 }
602
603 /*
604 * NAME: interpret->spread()
605 * DESCRIPTION: push the values in an array on the stack, return the size
606 * of the array - 1
607 */
i_spread(frame * f,int n,int vtype,Uint class)608 int i_spread(frame *f, int n, int vtype, Uint class)
609 {
610 array *a;
611 int i;
612 value *v;
613
614 if (f->sp->type != T_ARRAY) {
615 error("Spread of non-array");
616 }
617 a = f->sp->u.array;
618 if (n < 0 || n > a->size) {
619 /* no lvalues */
620 n = a->size;
621 }
622 if (a->size > 0) {
623 i_add_ticks(f, a->size);
624 i = a->size - n;
625 a->ref += i;
626 i_grow_stack(f, n + i * (3 + (vtype == T_CLASS)));
627 }
628 f->sp++;
629
630 /* values */
631 for (i = 0, v = d_get_elts(a); i < n; i++, v++) {
632 i_push_value(f, v);
633 }
634 /* lvalues */
635 for (n = a->size; i < n; i++) {
636 if (f->p_ctrl->flags & (CTRL_OLDVM | CTRL_COMPILED)) {
637 (--f->sp)->type = T_ALVALUE;
638 f->sp->oindex = vtype;
639 f->sp->u.array = a;
640 f->lip->type = T_INT;
641 (f->lip++)->u.number = i;
642 if (vtype == T_CLASS) {
643 f->lip->type = T_INT;
644 (f->lip++)->u.number = class;
645 }
646 } else {
647 --f->sp;
648 PUT_ARRVAL_NOREF(f->sp, a);
649 PUSH_INTVAL(f, i);
650 if (vtype == T_CLASS) {
651 PUSH_INTVAL(f, class);
652 }
653 PUSH_INTVAL(f, (LVAL_INDEX << 28) | (vtype << 24));
654 }
655 }
656
657 arr_del(a);
658 return n - 1;
659 }
660
661 /*
662 * NAME: interpret->global()
663 * DESCRIPTION: push a global value on the stack
664 */
i_global(frame * f,int inherit,int index)665 void i_global(frame *f, int inherit, int index)
666 {
667 i_add_ticks(f, 4);
668 inherit = UCHAR(f->ctrl->imap[f->p_index + inherit]);
669 inherit = f->ctrl->inherits[inherit].varoffset;
670 if (f->lwobj == (array *) NULL) {
671 i_push_value(f, d_get_variable(f->data, inherit + index));
672 } else {
673 i_push_value(f, &f->lwobj->elts[2 + inherit + index]);
674 }
675 }
676
677 /*
678 * NAME: interpret->global_lvalue()
679 * DESCRIPTION: push a global lvalue on the stack
680 */
i_global_lvalue(frame * f,int inherit,int index,int vtype,Uint class)681 void i_global_lvalue(frame *f, int inherit, int index, int vtype, Uint class)
682 {
683 i_add_ticks(f, 4);
684 inherit = UCHAR(f->ctrl->imap[f->p_index + inherit]);
685 inherit = f->ctrl->inherits[inherit].varoffset;
686 if (f->lwobj == (array *) NULL) {
687 (--f->sp)->type = T_LVALUE;
688 f->sp->oindex = vtype;
689 f->sp->u.lval = d_get_variable(f->data, inherit + index);
690 } else {
691 (--f->sp)->type = T_ALVALUE;
692 f->sp->oindex = vtype;
693 arr_ref(f->sp->u.array = f->lwobj);
694 f->lip->type = T_INT;
695 (f->lip++)->u.number = 2 + inherit + index;
696 }
697
698 if (vtype == T_CLASS) {
699 f->lip->type = T_INT;
700 (f->lip++)->u.number = class;
701 }
702 }
703
704 /*
705 * NAME: interpret->index()
706 * DESCRIPTION: index a value, REPLACING it with the indexed value
707 */
i_index(frame * f)708 void i_index(frame *f)
709 {
710 int i;
711 value *aval, *ival, *val;
712 array *a;
713
714 val = NULL;
715 i_add_ticks(f, 2);
716 ival = f->sp++;
717 aval = f->sp;
718 switch (aval->type) {
719 case T_STRING:
720 if (ival->type != T_INT) {
721 i_del_value(ival);
722 error("Non-numeric string index");
723 }
724 i = UCHAR(aval->u.string->text[str_index(aval->u.string,
725 (long) ival->u.number)]);
726 str_del(aval->u.string);
727 PUT_INTVAL(aval, i);
728 return;
729
730 case T_ARRAY:
731 if (ival->type != T_INT) {
732 i_del_value(ival);
733 error("Non-numeric array index");
734 }
735 val = &d_get_elts(aval->u.array)[arr_index(aval->u.array,
736 (long) ival->u.number)];
737 break;
738
739 case T_MAPPING:
740 val = map_index(f->data, aval->u.array, ival, (value *) NULL,
741 (value *) NULL);
742 i_del_value(ival);
743 break;
744
745 default:
746 i_del_value(ival);
747 error("Index on bad type");
748 }
749
750 a = aval->u.array;
751 switch (val->type) {
752 case T_STRING:
753 str_ref(val->u.string);
754 break;
755
756 case T_OBJECT:
757 if (DESTRUCTED(val)) {
758 val = &nil_value;
759 }
760 break;
761
762 case T_LWOBJECT:
763 ival = d_get_elts(val->u.array);
764 if (ival->type == T_OBJECT && DESTRUCTED(ival)) {
765 val = &nil_value;
766 break;
767 }
768 /* fall through */
769 case T_ARRAY:
770 case T_MAPPING:
771 arr_ref(val->u.array);
772 break;
773 }
774 *aval = *val;
775 arr_del(a);
776 }
777
778 /*
779 * NAME: interpret->index2()
780 * DESCRIPTION: index a value
781 */
i_index2(frame * f,value * aval,value * ival,value * val)782 void i_index2(frame *f, value *aval, value *ival, value *val)
783 {
784 int i;
785
786 i_add_ticks(f, 2);
787 switch (aval->type) {
788 case T_STRING:
789 if (ival->type != T_INT) {
790 i_del_value(ival);
791 error("Non-numeric string index");
792 }
793 i = UCHAR(aval->u.string->text[str_index(aval->u.string,
794 ival->u.number)]);
795 PUT_INTVAL(val, i);
796 return;
797
798 case T_ARRAY:
799 if (ival->type != T_INT) {
800 i_del_value(ival);
801 error("Non-numeric array index");
802 }
803 *val = d_get_elts(aval->u.array)[arr_index(aval->u.array,
804 ival->u.number)];
805 break;
806
807 case T_MAPPING:
808 *val = *map_index(f->data, aval->u.array, ival, NULL, NULL);
809 break;
810
811 default:
812 error("Index on bad type");
813 }
814
815 switch (val->type) {
816 case T_STRING:
817 str_ref(val->u.string);
818 break;
819
820 case T_OBJECT:
821 if (DESTRUCTED(val)) {
822 *val = nil_value;
823 }
824 break;
825
826 case T_LWOBJECT:
827 ival = d_get_elts(val->u.array);
828 if (ival->type == T_OBJECT && DESTRUCTED(ival)) {
829 *val = nil_value;
830 break;
831 }
832 /* fall through */
833 case T_ARRAY:
834 case T_MAPPING:
835 arr_ref(val->u.array);
836 break;
837 }
838 }
839
840 /*
841 * NAME: interpret->index_lvalue()
842 * DESCRIPTION: Index a value, REPLACING it by an indexed lvalue.
843 */
i_index_lvalue(frame * f,int vtype,Uint class)844 void i_index_lvalue(frame *f, int vtype, Uint class)
845 {
846 int i;
847 value *lval, *ival, *val;
848
849 i_add_ticks(f, 2);
850 ival = f->sp++;
851 lval = f->sp;
852 switch (lval->type) {
853 case T_STRING:
854 /* for instance, "foo"[1] = 'a'; */
855 i_del_value(ival);
856 error("Bad lvalue");
857
858 case T_ARRAY:
859 if (ival->type != T_INT) {
860 i_del_value(ival);
861 error("Non-numeric array index");
862 }
863 i = arr_index(lval->u.array, (long) ival->u.number);
864 lval->type = T_ALVALUE;
865 lval->oindex = vtype;
866 f->lip->type = T_INT;
867 (f->lip++)->u.number = i;
868 break;
869
870 case T_MAPPING:
871 lval->type = T_MLVALUE;
872 lval->oindex = vtype;
873 *f->lip++ = *ival;
874 break;
875
876 case T_LVALUE:
877 /*
878 * note: the lvalue is not yet referenced
879 */
880 switch (lval->u.lval->type) {
881 case T_STRING:
882 if (ival->type != T_INT) {
883 i_del_value(ival);
884 error("Non-numeric string index");
885 }
886 i = str_index(lval->u.lval->u.string, (long) ival->u.number);
887 lval->type = T_SLVALUE;
888 lval->oindex = vtype;
889 f->lip->type = T_STRING;
890 f->lip->oindex = i;
891 str_ref((f->lip++)->u.string = lval->u.lval->u.string);
892 break;
893
894 case T_ARRAY:
895 if (ival->type != T_INT) {
896 i_del_value(ival);
897 error("Non-numeric array index");
898 }
899 i = arr_index(lval->u.lval->u.array, (long) ival->u.number);
900 lval->type = T_ALVALUE;
901 lval->oindex = vtype;
902 arr_ref(lval->u.array = lval->u.lval->u.array);
903 f->lip->type = T_INT;
904 (f->lip++)->u.number = i;
905 break;
906
907 case T_MAPPING:
908 lval->type = T_MLVALUE;
909 lval->oindex = vtype;
910 arr_ref(lval->u.array = lval->u.lval->u.array);
911 *f->lip++ = *ival;
912 break;
913
914 default:
915 i_del_value(ival);
916 error("Index on bad type");
917 }
918 break;
919
920 case T_ALVALUE:
921 val = &d_get_elts(lval->u.array)[f->lip[-1].u.number];
922 switch (val->type) {
923 case T_STRING:
924 if (ival->type != T_INT) {
925 i_del_value(ival);
926 error("Non-numeric string index");
927 }
928 i = str_index(val->u.string, (long) ival->u.number);
929 lval->type = T_SALVALUE;
930 lval->oindex = vtype;
931 f->lip->type = T_STRING;
932 f->lip->oindex = i;
933 str_ref((f->lip++)->u.string = val->u.string);
934 break;
935
936 case T_ARRAY:
937 if (ival->type != T_INT) {
938 i_del_value(ival);
939 error("Non-numeric array index");
940 }
941 i = arr_index(val->u.array, (long) ival->u.number);
942 arr_ref(val->u.array); /* has to be first */
943 arr_del(lval->u.array); /* has to be second */
944 lval->oindex = vtype;
945 lval->u.array = val->u.array;
946 f->lip[-1].u.number = i;
947 break;
948
949 case T_MAPPING:
950 arr_ref(val->u.array); /* has to be first */
951 arr_del(lval->u.array); /* has to be second */
952 lval->type = T_MLVALUE;
953 lval->oindex = vtype;
954 lval->u.array = val->u.array;
955 f->lip[-1] = *ival;
956 break;
957
958 default:
959 i_del_value(ival);
960 error("Index on bad type");
961 }
962 break;
963
964 case T_MLVALUE:
965 val = map_index(f->data, lval->u.array, &f->lip[-1], (value *) NULL,
966 (value *) NULL);
967 switch (val->type) {
968 case T_STRING:
969 if (ival->type != T_INT) {
970 i_del_value(ival);
971 error("Non-numeric string index");
972 }
973 i = str_index(val->u.string, (long) ival->u.number);
974 lval->type = T_SMLVALUE;
975 lval->oindex = vtype;
976 f->lip->type = T_STRING;
977 f->lip->oindex = i;
978 str_ref((f->lip++)->u.string = val->u.string);
979 break;
980
981 case T_ARRAY:
982 if (ival->type != T_INT) {
983 i_del_value(ival);
984 error("Non-numeric array index");
985 }
986 i = arr_index(val->u.array, (long) ival->u.number);
987 arr_ref(val->u.array); /* has to be first */
988 arr_del(lval->u.array); /* has to be second */
989 lval->type = T_ALVALUE;
990 lval->oindex = vtype;
991 lval->u.array = val->u.array;
992 i_del_value(&f->lip[-1]);
993 f->lip[-1].type = T_INT;
994 f->lip[-1].u.number = i;
995 break;
996
997 case T_MAPPING:
998 arr_ref(val->u.array); /* has to be first */
999 arr_del(lval->u.array); /* has to be second */
1000 lval->oindex = vtype;
1001 lval->u.array = val->u.array;
1002 i_del_value(&f->lip[-1]);
1003 f->lip[-1] = *ival;
1004 break;
1005
1006 default:
1007 i_del_value(ival);
1008 error("Index on bad type");
1009 }
1010 break;
1011 }
1012
1013 if (vtype == T_CLASS) {
1014 f->lip->type = T_INT;
1015 (f->lip++)->u.number = class;
1016 }
1017 }
1018
1019 /*
1020 * NAME: interpret->typename()
1021 * DESCRIPTION: return the name of the argument type
1022 */
i_typename(char * buf,unsigned int type)1023 char *i_typename(char *buf, unsigned int type)
1024 {
1025 static char *name[] = TYPENAMES;
1026
1027 if ((type & T_TYPE) == T_CLASS) {
1028 type = (type & T_REF) | T_OBJECT;
1029 }
1030 strcpy(buf, name[type & T_TYPE]);
1031 type &= T_REF;
1032 type >>= REFSHIFT;
1033 if (type > 0) {
1034 char *p;
1035
1036 p = buf + strlen(buf);
1037 *p++ = ' ';
1038 do {
1039 *p++ = '*';
1040 } while (--type > 0);
1041 *p = '\0';
1042 }
1043 return buf;
1044 }
1045
1046 /*
1047 * NAME: interpret->classname()
1048 * DESCRIPTION: return the name of a class
1049 */
i_classname(frame * f,Uint class)1050 char *i_classname(frame *f, Uint class)
1051 {
1052 return d_get_strconst(f->p_ctrl, class >> 16, class & 0xffff)->text;
1053 }
1054
1055 /*
1056 * NAME: interpret->instanceof()
1057 * DESCRIPTION: is an object an instance of the named program?
1058 */
i_instanceof(frame * f,unsigned int oindex,Uint class)1059 int i_instanceof(frame *f, unsigned int oindex, Uint class)
1060 {
1061 inhash *h;
1062 char *prog;
1063 unsigned short i;
1064 dinherit *inh;
1065 object *obj;
1066 control *ctrl;
1067
1068 /* first try hash table */
1069 obj = OBJR(oindex);
1070 ctrl = o_control(obj);
1071 prog = i_classname(f, class);
1072 h = &ihash[(obj->count ^ (oindex << 2) ^ (f->p_ctrl->oindex << 4) ^ class) %
1073 INHASHSZ];
1074 if (h->ocount == obj->count && h->coindex == f->p_ctrl->oindex &&
1075 h->class == class && h->iindex < ctrl->ninherits) {
1076 oindex = ctrl->inherits[h->iindex].oindex;
1077 if (strcmp(OBJR(oindex)->chain.name, prog) == 0) {
1078 return (ctrl->inherits[h->iindex].priv) ? -1 : 1; /* found it */
1079 }
1080 }
1081
1082 /* next, search for it the hard way */
1083 for (i = ctrl->ninherits, inh = ctrl->inherits + i; i != 0; ) {
1084 --i;
1085 --inh;
1086 if (strcmp(prog, OBJR(inh->oindex)->chain.name) == 0) {
1087 /* found it; update hashtable */
1088 h->ocount = obj->count;
1089 h->coindex = f->p_ctrl->oindex;
1090 h->class = class;
1091 h->iindex = i;
1092 return (ctrl->inherits[i].priv) ? -1 : 1;
1093 }
1094 }
1095 return FALSE;
1096 }
1097
1098 /*
1099 * NAME: interpret->cast()
1100 * DESCRIPTION: cast a value to a type
1101 */
i_cast(frame * f,value * val,unsigned int type,Uint class)1102 void i_cast(frame *f, value *val, unsigned int type, Uint class)
1103 {
1104 char tnbuf[TNBUFSIZE];
1105 value *elts;
1106
1107 if (type == T_CLASS) {
1108 if (val->type == T_OBJECT) {
1109 if (!i_instanceof(f, val->oindex, class)) {
1110 error("Value is not of object type /%s", i_classname(f, class));
1111 }
1112 return;
1113 } else if (val->type == T_LWOBJECT) {
1114 elts = d_get_elts(val->u.array);
1115 if (elts->type == T_OBJECT) {
1116 if (!i_instanceof(f, elts->oindex, class)) {
1117 error("Value is not of object type /%s",
1118 i_classname(f, class));
1119 }
1120 } else if (strcmp(o_builtin_name(elts->u.number),
1121 i_classname(f, class)) != 0) {
1122 /*
1123 * builtin types can only be cast to their own type
1124 */
1125 error("Value is not of object type /%s", i_classname(f, class));
1126 }
1127 return;
1128 }
1129 type = T_OBJECT;
1130 }
1131 if (val->type != type && (val->type != T_LWOBJECT || type != T_OBJECT) &&
1132 (!VAL_NIL(val) || !T_POINTER(type))) {
1133 i_typename(tnbuf, type);
1134 if (strchr("aeiuoy", tnbuf[0]) != (char *) NULL) {
1135 error("Value is not an %s", tnbuf);
1136 } else {
1137 error("Value is not a %s", tnbuf);
1138 }
1139 }
1140 }
1141
1142 /*
1143 * NAME: interpret->dup()
1144 * DESCRIPTION: duplicate a value on the stack
1145 */
i_dup(frame * f)1146 void i_dup(frame *f)
1147 {
1148 switch (f->sp->type) {
1149 case T_LVALUE:
1150 i_push_value(f, f->sp->u.lval);
1151 break;
1152
1153 case T_ALVALUE:
1154 i_push_value(f, d_get_elts(f->sp->u.array) + f->lip[-1].u.number);
1155 break;
1156
1157 case T_MLVALUE:
1158 i_push_value(f, map_index(f->data, f->sp->u.array, &f->lip[-1],
1159 (value *) NULL, (value *) NULL));
1160 break;
1161
1162 case T_SLVALUE:
1163 case T_SALVALUE:
1164 case T_SMLVALUE:
1165 /*
1166 * Indexed string.
1167 */
1168 PUSH_INTVAL(f, UCHAR(f->lip[-1].u.string->text[f->lip[-1].oindex]));
1169 break;
1170
1171 default:
1172 i_push_value(f, f->sp);
1173 break;
1174 }
1175 }
1176
1177 /*
1178 * NAME: istr()
1179 * DESCRIPTION: create a copy of the argument string, with one char replaced
1180 */
istr(value * val,string * str,ssizet i,value * v)1181 static value *istr(value *val, string *str, ssizet i, value *v)
1182 {
1183 if (v->type != T_INT) {
1184 error("Non-numeric value in indexed string assignment");
1185 }
1186
1187 PUT_STRVAL_NOREF(val, (str->primary == (strref *) NULL && str->ref == 1) ?
1188 str : str_new(str->text, (long) str->len));
1189 val->u.string->text[i] = v->u.number;
1190 return val;
1191 }
1192
1193 /*
1194 * NAME: interpret->store_local()
1195 * DESCRIPTION: assign a value to a local variable
1196 */
i_store_local(frame * f,int local,value * val,value * verify)1197 static void i_store_local(frame *f, int local, value *val, value *verify)
1198 {
1199 value *var;
1200
1201 i_add_ticks(f, 1);
1202 var = (local < 0) ? f->fp + local : f->argp + local;
1203 if (verify == NULL ||
1204 (var->type == T_STRING && var->u.string == verify->u.string)) {
1205 d_assign_var(f->data, var, val);
1206 }
1207 }
1208
1209 /*
1210 * NAME: interpret->store_global()
1211 * DESCRIPTION: assign a value to a global variable
1212 */
i_store_global(frame * f,int inherit,int index,value * val,value * verify)1213 void i_store_global(frame *f, int inherit, int index, value *val, value *verify)
1214 {
1215 unsigned short offset;
1216 value *var;
1217
1218 i_add_ticks(f, 5);
1219 inherit = f->ctrl->imap[f->p_index + inherit];
1220 offset = f->ctrl->inherits[inherit].varoffset + index;
1221 if (f->lwobj == NULL) {
1222 var = d_get_variable(f->data, offset);
1223 if (verify == NULL ||
1224 (var->type == T_STRING && var->u.string == verify->u.string)) {
1225 d_assign_var(f->data, var, val);
1226 }
1227 } else {
1228 var = &f->lwobj->elts[2 + offset];
1229 if (verify == NULL ||
1230 (var->type == T_STRING && var->u.string == verify->u.string)) {
1231 d_assign_elt(f->data, f->lwobj, var, val);
1232 }
1233 }
1234 }
1235
1236 /*
1237 * NAME: interpret->store_index()
1238 * DESCRIPTION: perform an indexed assignment
1239 */
i_store_index(frame * f,value * var,value * aval,value * ival,value * val)1240 bool i_store_index(frame *f, value *var, value *aval, value *ival, value *val)
1241 {
1242 string *str;
1243 array *arr;
1244
1245 i_add_ticks(f, 3);
1246 switch (aval->type) {
1247 case T_STRING:
1248 if (ival->type != T_INT) {
1249 error("Non-numeric string index");
1250 }
1251 if (val->type != T_INT) {
1252 error("Non-numeric value in indexed string assignment");
1253 }
1254 str = str_new(aval->u.string->text, aval->u.string->len);
1255 str->text[str_index(str, ival->u.number)] = val->u.number;
1256 PUT_STRVAL(var, str);
1257 return TRUE;
1258
1259 case T_ARRAY:
1260 if (ival->type != T_INT) {
1261 error("Non-numeric array index");
1262 }
1263 arr = aval->u.array;
1264 aval = &d_get_elts(arr)[arr_index(arr, ival->u.number)];
1265 if (var->type != T_STRING ||
1266 (aval->type == T_STRING && var->u.string == aval->u.string)) {
1267 d_assign_elt(f->data, arr, aval, val);
1268 }
1269 arr_del(arr);
1270 break;
1271
1272 case T_MAPPING:
1273 arr = aval->u.array;
1274 if (var->type != T_STRING) {
1275 var = NULL;
1276 }
1277 map_index(f->data, arr, ival, val, var);
1278 i_del_value(ival);
1279 arr_del(arr);
1280 break;
1281
1282 default:
1283 error("Index on bad type");
1284 }
1285
1286 return FALSE;
1287 }
1288
1289 /*
1290 * NAME: interpret->store()
1291 * DESCRIPTION: Perform an assignment.
1292 */
i_store(frame * f)1293 void i_store(frame *f)
1294 {
1295 value *val;
1296 Uint class;
1297
1298 if (f->p_ctrl->flags & (CTRL_OLDVM | CTRL_COMPILED)) {
1299 value *lval;
1300 array *a;
1301 value ival;
1302
1303 lval = f->sp + 1;
1304 val = f->sp;
1305 if (lval->oindex != 0) {
1306 if (lval->oindex == T_CLASS) {
1307 --f->lip;
1308 class = f->lip->u.number;
1309 } else {
1310 class = 0;
1311 }
1312 i_cast(f, val, lval->oindex, class);
1313 }
1314
1315 i_add_ticks(f, 1);
1316 switch (lval->type) {
1317 case T_LVALUE:
1318 d_assign_var(f->data, lval->u.lval, val);
1319 break;
1320
1321 case T_SLVALUE:
1322 d_assign_var(f->data, lval->u.lval,
1323 istr(&ival, f->lip[-1].u.string, f->lip[-1].oindex,
1324 val));
1325 str_del((--f->lip)->u.string);
1326 break;
1327
1328 case T_ALVALUE:
1329 a = lval->u.array;
1330 d_assign_elt(f->data, a, &d_get_elts(a)[(--f->lip)->u.number], val);
1331 arr_del(a);
1332 break;
1333
1334 case T_MLVALUE:
1335 map_index(f->data, a = lval->u.array, &f->lip[-1], val,
1336 (value *) NULL);
1337 i_del_value(--f->lip);
1338 arr_del(a);
1339 break;
1340
1341 case T_SALVALUE:
1342 a = lval->u.array;
1343 d_assign_elt(f->data, a, &a->elts[f->lip[-2].u.number],
1344 istr(&ival, f->lip[-1].u.string, f->lip[-1].oindex,
1345 val));
1346 str_del((--f->lip)->u.string);
1347 --f->lip;
1348 arr_del(a);
1349 break;
1350
1351 case T_SMLVALUE:
1352 map_index(f->data, a = lval->u.array, &f->lip[-2],
1353 istr(&ival, f->lip[-1].u.string, f->lip[-1].oindex, val),
1354 (value *) NULL);
1355 str_del((--f->lip)->u.string);
1356 i_del_value(--f->lip);
1357 arr_del(a);
1358 break;
1359 }
1360 f->sp += 2;
1361 } else {
1362 Uint lval;
1363 int type;
1364 value var, *val, *tmp;
1365
1366 val = f->sp + 1;
1367 lval = (val++)->u.number;
1368 type = (lval >> 24) & 0xf;
1369 if (type == T_CLASS) {
1370 class = (val++)->u.number;
1371 } else {
1372 class = 0;
1373 }
1374 if (type != 0) {
1375 i_cast(f, f->sp, type, class);
1376 }
1377 tmp = f->sp;
1378 f->sp = val;
1379 val = tmp;
1380
1381 switch (lval >> 28) {
1382 case LVAL_LOCAL:
1383 i_store_local(f, SCHAR(lval), val, NULL);
1384 break;
1385
1386 case LVAL_GLOBAL:
1387 i_store_global(f, (lval >> 8) & 0xffff, UCHAR(lval), val, NULL);
1388 break;
1389
1390 case LVAL_INDEX:
1391 var = nil_value;
1392 if (i_store_index(f, &var, f->sp + 1, f->sp, val)) {
1393 str_del(f->sp[1].u.string);
1394 str_del(var.u.string);
1395 }
1396 f->sp += 2;
1397 break;
1398
1399 case LVAL_LOCAL_INDEX:
1400 var = nil_value;
1401 if (i_store_index(f, &var, f->sp + 1, f->sp, val)) {
1402 i_store_local(f, SCHAR(lval), &var, f->sp + 1);
1403 str_del(f->sp[1].u.string);
1404 str_del(var.u.string);
1405 }
1406 f->sp += 2;
1407 break;
1408
1409 case LVAL_GLOBAL_INDEX:
1410 var = nil_value;
1411 if (i_store_index(f, &var, f->sp + 1, f->sp, val)) {
1412 i_store_global(f, (lval >> 8) & 0xffff, UCHAR(lval), val,
1413 f->sp + 1);
1414 str_del(f->sp[1].u.string);
1415 str_del(var.u.string);
1416 }
1417 f->sp += 2;
1418 break;
1419
1420 case LVAL_INDEX_INDEX:
1421 var = nil_value;
1422 if (i_store_index(f, &var, f->sp + 1, f->sp, val)) {
1423 i_store_index(f, f->sp + 1, f->sp + 3, f->sp + 2, &var);
1424 str_del(f->sp[1].u.string);
1425 str_del(var.u.string);
1426 }
1427 f->sp += 4;
1428 break;
1429 }
1430 }
1431 }
1432
1433 /*
1434 * NAME: interpret->get_depth()
1435 * DESCRIPTION: get the remaining stack depth (-1: infinite)
1436 */
i_get_depth(frame * f)1437 Int i_get_depth(frame *f)
1438 {
1439 rlinfo *rlim;
1440
1441 rlim = f->rlim;
1442 if (rlim->nodepth) {
1443 return -1;
1444 }
1445 return rlim->maxdepth - f->depth;
1446 }
1447
1448 /*
1449 * NAME: interpret->get_ticks()
1450 * DESCRIPTION: get the remaining ticks (-1: infinite)
1451 */
i_get_ticks(frame * f)1452 Int i_get_ticks(frame *f)
1453 {
1454 rlinfo *rlim;
1455
1456 rlim = f->rlim;
1457 if (rlim->noticks) {
1458 return -1;
1459 } else {
1460 return (rlim->ticks < 0) ? 0 : rlim->ticks << f->level;
1461 }
1462 }
1463
1464 /*
1465 * NAME: interpret->check_rlimits()
1466 * DESCRIPTION: check if this rlimits call is valid
1467 */
i_check_rlimits(frame * f)1468 static void i_check_rlimits(frame *f)
1469 {
1470 object *obj;
1471
1472 obj = OBJR(f->oindex);
1473 if (obj->count == 0) {
1474 error("Illegal use of rlimits");
1475 }
1476 --f->sp;
1477 f->sp[0] = f->sp[1];
1478 f->sp[1] = f->sp[2];
1479 if (f->lwobj == (array *) NULL) {
1480 PUT_OBJVAL(&f->sp[2], obj);
1481 } else {
1482 PUT_LWOVAL(&f->sp[2], f->lwobj);
1483 }
1484
1485 /* obj, stack, ticks */
1486 call_driver_object(f, "runtime_rlimits", 3);
1487
1488 if (!VAL_TRUE(f->sp)) {
1489 error("Illegal use of rlimits");
1490 }
1491 i_del_value(f->sp++);
1492 }
1493
1494 /*
1495 * NAME: interpret->new_rlimits()
1496 * DESCRIPTION: create new rlimits scope
1497 */
i_new_rlimits(frame * f,Int depth,Int t)1498 void i_new_rlimits(frame *f, Int depth, Int t)
1499 {
1500 rlinfo *rlim;
1501
1502 rlim = ALLOC(rlinfo, 1);
1503 if (depth != 0) {
1504 if (depth < 0) {
1505 rlim->nodepth = TRUE;
1506 } else {
1507 rlim->maxdepth = f->depth + depth;
1508 rlim->nodepth = FALSE;
1509 }
1510 } else {
1511 rlim->maxdepth = f->rlim->maxdepth;
1512 rlim->nodepth = f->rlim->nodepth;
1513 }
1514 if (t != 0) {
1515 if (t < 0) {
1516 rlim->noticks = TRUE;
1517 } else {
1518 t >>= f->level;
1519 f->rlim->ticks -= t;
1520 rlim->ticks = t;
1521 rlim->noticks = FALSE;
1522 }
1523 } else {
1524 f->rlim->ticks = 0;
1525 rlim->ticks = f->rlim->ticks;
1526 rlim->noticks = f->rlim->noticks;
1527 }
1528
1529 rlim->next = f->rlim;
1530 f->rlim = rlim;
1531 }
1532
1533 /*
1534 * NAME: interpret->set_rlimits()
1535 * DESCRIPTION: restore rlimits to an earlier state
1536 */
i_set_rlimits(frame * f,rlinfo * rlim)1537 void i_set_rlimits(frame *f, rlinfo *rlim)
1538 {
1539 rlinfo *r, *next;
1540
1541 r = f->rlim;
1542 if (r->ticks < 0) {
1543 r->ticks = 0;
1544 }
1545 while (r != rlim) {
1546 next = r->next;
1547 if (!r->noticks) {
1548 next->ticks += r->ticks;
1549 }
1550 FREE(r);
1551 r = next;
1552 }
1553 f->rlim = rlim;
1554 }
1555
1556 /*
1557 * NAME: interpret->set_sp()
1558 * DESCRIPTION: set the current stack pointer
1559 */
i_set_sp(frame * ftop,value * sp)1560 frame *i_set_sp(frame *ftop, value *sp)
1561 {
1562 value *v, *w;
1563 frame *f;
1564
1565 for (f = ftop; ; f = f->prev) {
1566 v = f->sp;
1567 w = f->lip;
1568 for (;;) {
1569 if (v == sp) {
1570 f->sp = v;
1571 f->lip = w;
1572 return f;
1573 }
1574 if (v == f->fp) {
1575 break;
1576 }
1577 switch (v->type) {
1578 case T_STRING:
1579 str_del(v->u.string);
1580 break;
1581
1582 case T_LVALUE:
1583 if (v->oindex == T_CLASS) {
1584 --w;
1585 }
1586 break;
1587
1588 case T_SLVALUE:
1589 if (v->oindex == T_CLASS) {
1590 --w;
1591 }
1592 str_del((--w)->u.string);
1593 break;
1594
1595 case T_ALVALUE:
1596 if (v->oindex == T_CLASS) {
1597 --w;
1598 }
1599 --w;
1600 case T_ARRAY:
1601 case T_MAPPING:
1602 case T_LWOBJECT:
1603 arr_del(v->u.array);
1604 break;
1605
1606 case T_MLVALUE:
1607 if (v->oindex == T_CLASS) {
1608 --w;
1609 }
1610 i_del_value(--w);
1611 arr_del(v->u.array);
1612 break;
1613
1614 case T_SALVALUE:
1615 if (v->oindex == T_CLASS) {
1616 --w;
1617 }
1618 str_del((--w)->u.string);
1619 --w;
1620 arr_del(v->u.array);
1621 break;
1622
1623 case T_SMLVALUE:
1624 if (v->oindex == T_CLASS) {
1625 --w;
1626 }
1627 str_del((--w)->u.string);
1628 i_del_value(--w);
1629 arr_del(v->u.array);
1630 break;
1631 }
1632 v++;
1633 }
1634
1635 if (f->lwobj != (array *) NULL) {
1636 arr_del(f->lwobj);
1637 }
1638 if (f->sos) {
1639 /* stack on stack */
1640 AFREE(f->stack);
1641 } else if (f->oindex != OBJ_NONE) {
1642 FREE(f->stack);
1643 }
1644 }
1645 }
1646
1647 /*
1648 * NAME: interpret->prev_object()
1649 * DESCRIPTION: return the nth previous object in the call_other chain
1650 */
i_prev_object(frame * f,int n)1651 frame *i_prev_object(frame *f, int n)
1652 {
1653 while (n >= 0) {
1654 /* back to last external call */
1655 while (!f->external) {
1656 f = f->prev;
1657 }
1658 f = f->prev;
1659 if (f->oindex == OBJ_NONE) {
1660 return (frame *) NULL;
1661 }
1662 --n;
1663 }
1664 return f;
1665 }
1666
1667 /*
1668 * NAME: interpret->prev_program()
1669 * DESCRIPTION: return the nth previous program in the function call chain
1670 */
i_prev_program(frame * f,int n)1671 char *i_prev_program(frame *f, int n)
1672 {
1673 while (n >= 0) {
1674 f = f->prev;
1675 if (f->oindex == OBJ_NONE) {
1676 return (char *) NULL;
1677 }
1678 --n;
1679 }
1680
1681 return OBJR(f->p_ctrl->oindex)->chain.name;
1682 }
1683
1684 /*
1685 * NAME: interpret->typecheck()
1686 * DESCRIPTION: check the argument types given to a function
1687 */
i_typecheck(frame * f,frame * prog_f,char * name,char * ftype,char * proto,int nargs,int strict)1688 void i_typecheck(frame *f, frame *prog_f, char *name, char *ftype, char *proto, int nargs, int strict)
1689 {
1690 char tnbuf[TNBUFSIZE];
1691 int i, n, atype, ptype;
1692 char *args;
1693 bool ellipsis;
1694 Uint class;
1695 value *elts;
1696
1697 class = 0;
1698 i = nargs;
1699 n = PROTO_NARGS(proto) + PROTO_VARGS(proto);
1700 ellipsis = (PROTO_CLASS(proto) & C_ELLIPSIS);
1701 args = PROTO_ARGS(proto);
1702 while (n > 0 && i > 0) {
1703 --i;
1704 ptype = *args++;
1705 if ((ptype & T_TYPE) == T_CLASS) {
1706 FETCH3U(args, class);
1707 }
1708 if (n == 1 && ellipsis) {
1709 if (ptype == T_MIXED || ptype == T_LVALUE) {
1710 return;
1711 }
1712 if ((ptype & T_TYPE) == T_CLASS) {
1713 args -= 4;
1714 } else {
1715 --args;
1716 }
1717 } else {
1718 --n;
1719 }
1720
1721 if (ptype != T_MIXED) {
1722 atype = f->sp[i].type;
1723 if (atype == T_LWOBJECT) {
1724 atype = T_OBJECT;
1725 }
1726 if ((ptype & T_TYPE) == T_CLASS && ptype == T_CLASS &&
1727 atype == T_OBJECT) {
1728 if (f->sp[i].type == T_OBJECT) {
1729 if (!i_instanceof(prog_f, f->sp[i].oindex, class)) {
1730 error("Bad object argument %d for function %s",
1731 nargs - i, name);
1732 }
1733 } else {
1734 elts = d_get_elts(f->sp[i].u.array);
1735 if (elts->type == T_OBJECT) {
1736 if (!i_instanceof(prog_f, elts->oindex, class)) {
1737 error("Bad object argument %d for function %s",
1738 nargs - i, name);
1739 }
1740 } else if (strcmp(o_builtin_name(elts->u.number),
1741 i_classname(prog_f, class)) != 0) {
1742 error("Bad object argument %d for function %s",
1743 nargs - i, name);
1744 }
1745 }
1746 continue;
1747 }
1748 if (ptype != atype && (atype != T_ARRAY || !(ptype & T_REF))) {
1749 if (!VAL_NIL(f->sp + i) || !T_POINTER(ptype)) {
1750 /* wrong type */
1751 error("Bad argument %d (%s) for %s %s", nargs - i,
1752 i_typename(tnbuf, atype), ftype, name);
1753 } else if (strict) {
1754 /* nil argument */
1755 error("Bad argument %d for %s %s", nargs - i, ftype, name);
1756 }
1757 }
1758 }
1759 }
1760 }
1761
1762 /*
1763 * NAME: interpret->switch_int()
1764 * DESCRIPTION: handle an int switch
1765 */
i_switch_int(frame * f,char * pc)1766 static unsigned short i_switch_int(frame *f, char *pc)
1767 {
1768 unsigned short h, l, m, sz, dflt;
1769 Int num;
1770 char *p;
1771
1772 FETCH2U(pc, h);
1773 sz = FETCH1U(pc);
1774 FETCH2U(pc, dflt);
1775 if (f->sp->type != T_INT) {
1776 return dflt;
1777 }
1778
1779 l = 0;
1780 --h;
1781 switch (sz) {
1782 case 1:
1783 while (l < h) {
1784 m = (l + h) >> 1;
1785 p = pc + 3 * m;
1786 num = FETCH1S(p);
1787 if (f->sp->u.number == num) {
1788 return FETCH2U(p, l);
1789 } else if (f->sp->u.number < num) {
1790 h = m; /* search in lower half */
1791 } else {
1792 l = m + 1; /* search in upper half */
1793 }
1794 }
1795 break;
1796
1797 case 2:
1798 while (l < h) {
1799 m = (l + h) >> 1;
1800 p = pc + 4 * m;
1801 FETCH2S(p, num);
1802 if (f->sp->u.number == num) {
1803 return FETCH2U(p, l);
1804 } else if (f->sp->u.number < num) {
1805 h = m; /* search in lower half */
1806 } else {
1807 l = m + 1; /* search in upper half */
1808 }
1809 }
1810 break;
1811
1812 case 3:
1813 while (l < h) {
1814 m = (l + h) >> 1;
1815 p = pc + 5 * m;
1816 FETCH3S(p, num);
1817 if (f->sp->u.number == num) {
1818 return FETCH2U(p, l);
1819 } else if (f->sp->u.number < num) {
1820 h = m; /* search in lower half */
1821 } else {
1822 l = m + 1; /* search in upper half */
1823 }
1824 }
1825 break;
1826
1827 case 4:
1828 while (l < h) {
1829 m = (l + h) >> 1;
1830 p = pc + 6 * m;
1831 FETCH4S(p, num);
1832 if (f->sp->u.number == num) {
1833 return FETCH2U(p, l);
1834 } else if (f->sp->u.number < num) {
1835 h = m; /* search in lower half */
1836 } else {
1837 l = m + 1; /* search in upper half */
1838 }
1839 }
1840 break;
1841 }
1842
1843 return dflt;
1844 }
1845
1846 /*
1847 * NAME: interpret->switch_range()
1848 * DESCRIPTION: handle a range switch
1849 */
i_switch_range(frame * f,char * pc)1850 static unsigned short i_switch_range(frame *f, char *pc)
1851 {
1852 unsigned short h, l, m, sz, dflt;
1853 Int num;
1854 char *p;
1855
1856 FETCH2U(pc, h);
1857 sz = FETCH1U(pc);
1858 FETCH2U(pc, dflt);
1859 if (f->sp->type != T_INT) {
1860 return dflt;
1861 }
1862
1863 l = 0;
1864 --h;
1865 switch (sz) {
1866 case 1:
1867 while (l < h) {
1868 m = (l + h) >> 1;
1869 p = pc + 4 * m;
1870 num = FETCH1S(p);
1871 if (f->sp->u.number < num) {
1872 h = m; /* search in lower half */
1873 } else {
1874 num = FETCH1S(p);
1875 if (f->sp->u.number <= num) {
1876 return FETCH2U(p, l);
1877 }
1878 l = m + 1; /* search in upper half */
1879 }
1880 }
1881 break;
1882
1883 case 2:
1884 while (l < h) {
1885 m = (l + h) >> 1;
1886 p = pc + 6 * m;
1887 FETCH2S(p, num);
1888 if (f->sp->u.number < num) {
1889 h = m; /* search in lower half */
1890 } else {
1891 FETCH2S(p, num);
1892 if (f->sp->u.number <= num) {
1893 return FETCH2U(p, l);
1894 }
1895 l = m + 1; /* search in upper half */
1896 }
1897 }
1898 break;
1899
1900 case 3:
1901 while (l < h) {
1902 m = (l + h) >> 1;
1903 p = pc + 8 * m;
1904 FETCH3S(p, num);
1905 if (f->sp->u.number < num) {
1906 h = m; /* search in lower half */
1907 } else {
1908 FETCH3S(p, num);
1909 if (f->sp->u.number <= num) {
1910 return FETCH2U(p, l);
1911 }
1912 l = m + 1; /* search in upper half */
1913 }
1914 }
1915 break;
1916
1917 case 4:
1918 while (l < h) {
1919 m = (l + h) >> 1;
1920 p = pc + 10 * m;
1921 FETCH4S(p, num);
1922 if (f->sp->u.number < num) {
1923 h = m; /* search in lower half */
1924 } else {
1925 FETCH4S(p, num);
1926 if (f->sp->u.number <= num) {
1927 return FETCH2U(p, l);
1928 }
1929 l = m + 1; /* search in upper half */
1930 }
1931 }
1932 break;
1933 }
1934 return dflt;
1935 }
1936
1937 /*
1938 * NAME: interpret->switch_str()
1939 * DESCRIPTION: handle a string switch
1940 */
i_switch_str(frame * f,char * pc)1941 static unsigned short i_switch_str(frame *f, char *pc)
1942 {
1943 unsigned short h, l, m, u, u2, dflt;
1944 int cmp;
1945 char *p;
1946 control *ctrl;
1947
1948 FETCH2U(pc, h);
1949 FETCH2U(pc, dflt);
1950 if (FETCH1U(pc) == 0) {
1951 FETCH2U(pc, l);
1952 if (VAL_NIL(f->sp)) {
1953 return l;
1954 }
1955 --h;
1956 }
1957 if (f->sp->type != T_STRING) {
1958 return dflt;
1959 }
1960
1961 ctrl = f->p_ctrl;
1962 l = 0;
1963 --h;
1964 while (l < h) {
1965 m = (l + h) >> 1;
1966 p = pc + 5 * m;
1967 u = FETCH1U(p);
1968 cmp = str_cmp(f->sp->u.string, d_get_strconst(ctrl, u, FETCH2U(p, u2)));
1969 if (cmp == 0) {
1970 return FETCH2U(p, l);
1971 } else if (cmp < 0) {
1972 h = m; /* search in lower half */
1973 } else {
1974 l = m + 1; /* search in upper half */
1975 }
1976 }
1977 return dflt;
1978 }
1979
1980 /*
1981 * NAME: interpret->catcherr()
1982 * DESCRIPTION: handle caught error
1983 */
i_catcherr(frame * f,Int depth)1984 void i_catcherr(frame *f, Int depth)
1985 {
1986 i_runtime_error(f, depth);
1987 }
1988
1989 /*
1990 * NAME: interpret->interpret0()
1991 * DESCRIPTION: Old interpreter function. Interpret stack machine code.
1992 */
i_interpret0(frame * f,char * pc)1993 static void i_interpret0(frame *f, char *pc)
1994 {
1995 unsigned short instr, u, u2;
1996 Uint l;
1997 char *p;
1998 kfunc *kf;
1999 int size;
2000 bool atomic;
2001 Int newdepth, newticks;
2002
2003 size = 0;
2004 l = 0;
2005
2006 for (;;) {
2007 # ifdef DEBUG
2008 if (f->sp < f->lip + MIN_STACK) {
2009 fatal("out of value stack");
2010 }
2011 # endif
2012 if (--f->rlim->ticks <= 0) {
2013 if (f->rlim->noticks) {
2014 f->rlim->ticks = 0x7fffffff;
2015 } else {
2016 error("Out of ticks");
2017 }
2018 }
2019 instr = FETCH1U(pc);
2020 f->pc = pc;
2021
2022 switch (instr & I_INSTR_MASK) {
2023 case II_PUSH_ZERO:
2024 PUSH_INTVAL(f, 0);
2025 break;
2026
2027 case II_PUSH_ONE:
2028 PUSH_INTVAL(f, 1);
2029 break;
2030
2031 case II_PUSH_INT1:
2032 PUSH_INTVAL(f, FETCH1S(pc));
2033 break;
2034
2035 case II_PUSH_INT4:
2036 PUSH_INTVAL(f, FETCH4S(pc, l));
2037 break;
2038
2039 case II_PUSH_FLOAT:
2040 FETCH2U(pc, u);
2041 PUSH_FLTCONST(f, u, FETCH4U(pc, l));
2042 break;
2043
2044 case II_PUSH_STRING:
2045 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, f->p_ctrl->ninherits - 1,
2046 FETCH1U(pc)));
2047 break;
2048
2049 case II_PUSH_NEAR_STRING:
2050 u = FETCH1U(pc);
2051 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, u, FETCH1U(pc)));
2052 break;
2053
2054 case II_PUSH_FAR_STRING:
2055 u = FETCH1U(pc);
2056 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, u, FETCH2U(pc, u2)));
2057 break;
2058
2059 case II_PUSH_LOCAL:
2060 u = FETCH1S(pc);
2061 i_push_value(f, ((short) u < 0) ? f->fp + (short) u : f->argp + u);
2062 break;
2063
2064 case II_PUSH_GLOBAL:
2065 i_global(f, f->p_ctrl->progindex, FETCH1U(pc));
2066 break;
2067
2068 case II_PUSH_FAR_GLOBAL:
2069 u = FETCH1U(pc);
2070 i_global(f, u, FETCH1U(pc));
2071 break;
2072
2073 case II_PUSH_LOCAL_LVAL:
2074 u = FETCH1S(pc);
2075 if (instr & I_TYPE_BIT) {
2076 instr = FETCH1U(pc);
2077 if (instr == T_CLASS) {
2078 FETCH3U(pc, l);
2079 f->lip->type = T_INT;
2080 (f->lip++)->u.number = l;
2081 }
2082 } else {
2083 instr = 0;
2084 }
2085 (--f->sp)->type = T_LVALUE;
2086 f->sp->oindex = instr;
2087 f->sp->u.lval = ((short) u < 0) ? f->fp + (short) u : f->argp + u;
2088 continue;
2089
2090 case II_PUSH_GLOBAL_LVAL:
2091 u = FETCH1U(pc);
2092 if (instr & I_TYPE_BIT) {
2093 instr = FETCH1U(pc);
2094 if (instr == T_CLASS) {
2095 FETCH3U(pc, l);
2096 }
2097 } else {
2098 instr = 0;
2099 }
2100 i_global_lvalue(f, f->p_ctrl->progindex, u, instr, l);
2101 continue;
2102
2103 case II_PUSH_FAR_GLOBAL_LVAL:
2104 u = FETCH1U(pc);
2105 u2 = FETCH1U(pc);
2106 if (instr & I_TYPE_BIT) {
2107 instr = FETCH1U(pc);
2108 if (instr == T_CLASS) {
2109 FETCH3U(pc, l);
2110 }
2111 } else {
2112 instr = 0;
2113 }
2114 i_global_lvalue(f, u, u2, instr, l);
2115 continue;
2116
2117 case II_INDEX:
2118 i_index(f);
2119 break;
2120
2121 case II_INDEX_LVAL:
2122 if (instr & I_TYPE_BIT) {
2123 instr = FETCH1U(pc);
2124 if (instr == T_CLASS) {
2125 FETCH3U(pc, l);
2126 }
2127 } else {
2128 instr = 0;
2129 }
2130 i_index_lvalue(f, instr, l);
2131 continue;
2132
2133 case II_AGGREGATE:
2134 if (FETCH1U(pc) == 0) {
2135 i_aggregate(f, FETCH2U(pc, u));
2136 } else {
2137 i_map_aggregate(f, FETCH2U(pc, u));
2138 }
2139 break;
2140
2141 case II_SPREAD:
2142 u = FETCH1S(pc);
2143 if (instr & I_TYPE_BIT) {
2144 instr = FETCH1U(pc);
2145 if (instr == T_CLASS) {
2146 FETCH3U(pc, l);
2147 }
2148 } else {
2149 instr = 0;
2150 }
2151 size = i_spread(f, (short) u, instr, l);
2152 continue;
2153
2154 case II_CAST:
2155 u = FETCH1U(pc);
2156 if (u == T_CLASS) {
2157 FETCH3U(pc, l);
2158 }
2159 i_cast(f, f->sp, u, l);
2160 break;
2161
2162 case II_DUP:
2163 i_dup(f);
2164 break;
2165
2166 case II_STORE:
2167 i_store(f);
2168 --f->sp;
2169 f->sp[0] = f->sp[-1];
2170 break;
2171
2172 case II_JUMP:
2173 p = f->prog + FETCH2U(pc, u);
2174 pc = p;
2175 break;
2176
2177 case II_JUMP_ZERO:
2178 p = f->prog + FETCH2U(pc, u);
2179 if (!VAL_TRUE(f->sp)) {
2180 pc = p;
2181 }
2182 break;
2183
2184 case II_JUMP_NONZERO:
2185 p = f->prog + FETCH2U(pc, u);
2186 if (VAL_TRUE(f->sp)) {
2187 pc = p;
2188 }
2189 break;
2190
2191 case II_SWITCH:
2192 switch (FETCH1U(pc)) {
2193 case SWITCH_INT:
2194 pc = f->prog + i_switch_int(f, pc);
2195 break;
2196
2197 case SWITCH_RANGE:
2198 pc = f->prog + i_switch_range(f, pc);
2199 break;
2200
2201 case SWITCH_STRING:
2202 pc = f->prog + i_switch_str(f, pc);
2203 break;
2204 }
2205 break;
2206
2207 case II_CALL_KFUNC:
2208 kf = &KFUN(FETCH1U(pc));
2209 if (PROTO_VARGS(kf->proto) != 0) {
2210 /* variable # of arguments */
2211 u = FETCH1U(pc) + size;
2212 size = 0;
2213 } else {
2214 /* fixed # of arguments */
2215 u = PROTO_NARGS(kf->proto);
2216 }
2217 if (PROTO_CLASS(kf->proto) & C_TYPECHECKED) {
2218 i_typecheck(f, (frame *) NULL, kf->name, "kfun", kf->proto, u,
2219 TRUE);
2220 }
2221 u = (*kf->func)(f, u, kf);
2222 if (u != 0) {
2223 if ((short) u < 0) {
2224 error("Too few arguments for kfun %s", kf->name);
2225 } else if (u <= PROTO_NARGS(kf->proto) + PROTO_VARGS(kf->proto))
2226 {
2227 error("Bad argument %d for kfun %s", u, kf->name);
2228 } else {
2229 error("Too many arguments for kfun %s", kf->name);
2230 }
2231 }
2232 break;
2233
2234 case II_CALL_AFUNC:
2235 u = FETCH1U(pc);
2236 i_funcall(f, (object *) NULL, (array *) NULL, 0, u,
2237 FETCH1U(pc) + size);
2238 size = 0;
2239 break;
2240
2241 case II_CALL_DFUNC:
2242 u = UCHAR(f->ctrl->imap[f->p_index + FETCH1U(pc)]);
2243 u2 = FETCH1U(pc);
2244 i_funcall(f, (object *) NULL, (array *) NULL, u, u2,
2245 FETCH1U(pc) + size);
2246 size = 0;
2247 break;
2248
2249 case II_CALL_FUNC:
2250 p = &f->ctrl->funcalls[2L * (f->foffset + FETCH2U(pc, u))];
2251 i_funcall(f, (object *) NULL, (array *) NULL, UCHAR(p[0]),
2252 UCHAR(p[1]), FETCH1U(pc) + size);
2253 size = 0;
2254 break;
2255
2256 case II_CATCH:
2257 atomic = f->atomic;
2258 p = f->prog + FETCH2U(pc, u);
2259 if (!ec_push((ec_ftn) i_catcherr)) {
2260 f->atomic = FALSE;
2261 i_interpret0(f, pc);
2262 ec_pop();
2263 pc = f->pc;
2264 *--f->sp = nil_value;
2265 } else {
2266 /* error */
2267 f->pc = pc = p;
2268 PUSH_STRVAL(f, errorstr());
2269 }
2270 f->atomic = atomic;
2271 break;
2272
2273 case II_RLIMITS:
2274 if (f->sp[1].type != T_INT) {
2275 error("Bad rlimits depth type");
2276 }
2277 if (f->sp->type != T_INT) {
2278 error("Bad rlimits ticks type");
2279 }
2280 newdepth = f->sp[1].u.number;
2281 newticks = f->sp->u.number;
2282 if (!FETCH1U(pc)) {
2283 /* runtime check */
2284 i_check_rlimits(f);
2285 } else {
2286 /* pop limits */
2287 f->sp += 2;
2288 }
2289
2290 i_new_rlimits(f, newdepth, newticks);
2291 i_interpret0(f, pc);
2292 pc = f->pc;
2293 i_set_rlimits(f, f->rlim->next);
2294 break;
2295
2296 case II_RETURN:
2297 return;
2298 }
2299
2300 if (instr & I_POP_BIT) {
2301 /* pop the result of the last operation (never an lvalue) */
2302 i_del_value(f->sp++);
2303 }
2304 }
2305 }
2306
2307 /*
2308 * NAME: interpret->interpret1()
2309 * DESCRIPTION: Main interpreter function v1. Interpret stack machine code.
2310 */
i_interpret1(frame * f,char * pc)2311 static void i_interpret1(frame *f, char *pc)
2312 {
2313 unsigned short instr, u, u2;
2314 Uint l;
2315 char *p;
2316 kfunc *kf;
2317 int size;
2318 bool atomic;
2319 Int newdepth, newticks;
2320 value val;
2321
2322 size = 0;
2323 l = 0;
2324
2325 for (;;) {
2326 # ifdef DEBUG
2327 if (f->sp < f->lip + MIN_STACK) {
2328 fatal("out of value stack");
2329 }
2330 # endif
2331 if (--f->rlim->ticks <= 0) {
2332 if (f->rlim->noticks) {
2333 f->rlim->ticks = 0x7fffffff;
2334 } else {
2335 error("Out of ticks");
2336 }
2337 }
2338 instr = FETCH1U(pc);
2339 f->pc = pc;
2340
2341 switch (instr & I_EINSTR_MASK) {
2342 case I_PUSH_INT1:
2343 PUSH_INTVAL(f, FETCH1S(pc));
2344 continue;
2345
2346 case I_PUSH_INT2:
2347 PUSH_INTVAL(f, FETCH2S(pc, u));
2348 continue;
2349
2350 case I_PUSH_INT4:
2351 PUSH_INTVAL(f, FETCH4S(pc, l));
2352 continue;
2353
2354 case I_PUSH_FLOAT6:
2355 FETCH2U(pc, u);
2356 PUSH_FLTCONST(f, u, FETCH4U(pc, l));
2357 continue;
2358
2359 case I_PUSH_STRING:
2360 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, f->p_ctrl->ninherits - 1,
2361 FETCH1U(pc)));
2362 continue;
2363
2364 case I_PUSH_NEAR_STRING:
2365 u = FETCH1U(pc);
2366 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, u, FETCH1U(pc)));
2367 continue;
2368
2369 case I_PUSH_FAR_STRING:
2370 u = FETCH1U(pc);
2371 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, u, FETCH2U(pc, u2)));
2372 continue;
2373
2374 case I_PUSH_LOCAL:
2375 u = FETCH1S(pc);
2376 i_push_value(f, ((short) u < 0) ? f->fp + (short) u : f->argp + u);
2377 continue;
2378
2379 case I_PUSH_GLOBAL:
2380 i_global(f, f->p_ctrl->ninherits - 1, FETCH1U(pc));
2381 continue;
2382
2383 case I_PUSH_FAR_GLOBAL:
2384 u = FETCH1U(pc);
2385 i_global(f, u, FETCH1U(pc));
2386 continue;
2387
2388 case I_INDEX:
2389 case I_INDEX | I_POP_BIT:
2390 i_index(f);
2391 break;
2392
2393 case I_INDEX2:
2394 --f->sp;
2395 i_index2(f, f->sp + 2, f->sp + 1, f->sp);
2396 continue;
2397
2398 case I_AGGREGATE:
2399 case I_AGGREGATE | I_POP_BIT:
2400 if (FETCH1U(pc) == 0) {
2401 i_aggregate(f, FETCH2U(pc, u));
2402 } else {
2403 i_map_aggregate(f, FETCH2U(pc, u));
2404 }
2405 break;
2406
2407 case I_SPREAD:
2408 u = FETCH1S(pc);
2409 if ((short) u >= 0) {
2410 u2 = FETCH1U(pc);
2411 if (u2 == T_CLASS) {
2412 FETCH3U(pc, l);
2413 }
2414 } else {
2415 u2 = 0;
2416 }
2417 size = i_spread(f, (short) u, u2, l);
2418 continue;
2419
2420 case I_CAST:
2421 case I_CAST | I_POP_BIT:
2422 u = FETCH1U(pc);
2423 if (u == T_CLASS) {
2424 FETCH3U(pc, l);
2425 }
2426 i_cast(f, f->sp, u, l);
2427 break;
2428
2429 case I_STORE_LOCAL:
2430 case I_STORE_LOCAL | I_POP_BIT:
2431 i_store_local(f, FETCH1S(pc), f->sp, NULL);
2432 break;
2433
2434 case I_STORE_GLOBAL:
2435 case I_STORE_GLOBAL | I_POP_BIT:
2436 i_store_global(f, f->p_ctrl->ninherits - 1, FETCH1U(pc), f->sp,
2437 NULL);
2438 break;
2439
2440 case I_STORE_FAR_GLOBAL:
2441 case I_STORE_FAR_GLOBAL | I_POP_BIT:
2442 u = FETCH1U(pc);
2443 i_store_global(f, u, FETCH1U(pc), f->sp, NULL);
2444 break;
2445
2446 case I_STORE_INDEX:
2447 case I_STORE_INDEX | I_POP_BIT:
2448 val = nil_value;
2449 if (i_store_index(f, &val, f->sp + 2, f->sp + 1, f->sp)) {
2450 str_del(f->sp[2].u.string);
2451 str_del(val.u.string);
2452 }
2453 f->sp[2] = f->sp[0];
2454 f->sp += 2;
2455 break;
2456
2457 case I_STORE_LOCAL_INDEX:
2458 case I_STORE_LOCAL_INDEX | I_POP_BIT:
2459 u = FETCH1S(pc);
2460 val = nil_value;
2461 if (i_store_index(f, &val, f->sp + 2, f->sp + 1, f->sp)) {
2462 i_store_local(f, (short) u, &val, f->sp + 2);
2463 str_del(f->sp[2].u.string);
2464 str_del(val.u.string);
2465 }
2466 f->sp[2] = f->sp[0];
2467 f->sp += 2;
2468 break;
2469
2470 case I_STORE_GLOBAL_INDEX:
2471 case I_STORE_GLOBAL_INDEX | I_POP_BIT:
2472 u = FETCH1U(pc);
2473 u2 = FETCH1U(pc);
2474 val = nil_value;
2475 if (i_store_index(f, &val, f->sp + 2, f->sp + 1, f->sp)) {
2476 i_store_global(f, u, u2, &val, f->sp + 2);
2477 str_del(f->sp[2].u.string);
2478 str_del(val.u.string);
2479 }
2480 f->sp[2] = f->sp[0];
2481 f->sp += 2;
2482 break;
2483
2484 case I_STORE_INDEX_INDEX:
2485 case I_STORE_INDEX_INDEX | I_POP_BIT:
2486 val = nil_value;
2487 if (i_store_index(f, &val, f->sp + 2, f->sp + 1, f->sp)) {
2488 i_store_index(f, f->sp + 2, f->sp + 4, f->sp + 3, &val);
2489 str_del(f->sp[2].u.string);
2490 str_del(val.u.string);
2491 } else {
2492 i_del_value(f->sp + 3);
2493 i_del_value(f->sp + 4);
2494 }
2495 f->sp[4] = f->sp[0];
2496 f->sp += 4;
2497 break;
2498
2499 case I_JUMP_ZERO:
2500 p = f->prog + FETCH2U(pc, u);
2501 if (!VAL_TRUE(f->sp)) {
2502 pc = p;
2503 }
2504 i_del_value(f->sp++);
2505 continue;
2506
2507 case I_JUMP_NONZERO:
2508 p = f->prog + FETCH2U(pc, u);
2509 if (VAL_TRUE(f->sp)) {
2510 pc = p;
2511 }
2512 i_del_value(f->sp++);
2513 continue;
2514
2515 case I_JUMP:
2516 p = f->prog + FETCH2U(pc, u);
2517 pc = p;
2518 continue;
2519
2520 case I_SWITCH:
2521 switch (FETCH1U(pc)) {
2522 case SWITCH_INT:
2523 pc = f->prog + i_switch_int(f, pc);
2524 break;
2525
2526 case SWITCH_RANGE:
2527 pc = f->prog + i_switch_range(f, pc);
2528 break;
2529
2530 case SWITCH_STRING:
2531 pc = f->prog + i_switch_str(f, pc);
2532 break;
2533 }
2534 i_del_value(f->sp++);
2535 continue;
2536
2537 case I_CALL_KFUNC:
2538 case I_CALL_KFUNC | I_POP_BIT:
2539 kf = &KFUN(FETCH1U(pc));
2540 if (PROTO_VARGS(kf->proto) != 0) {
2541 /* variable # of arguments */
2542 u = FETCH1U(pc) + size;
2543 size = 0;
2544 } else {
2545 /* fixed # of arguments */
2546 u = PROTO_NARGS(kf->proto);
2547 }
2548 if (PROTO_CLASS(kf->proto) & C_TYPECHECKED) {
2549 i_typecheck(f, (frame *) NULL, kf->name, "kfun", kf->proto, u,
2550 TRUE);
2551 }
2552 u = (*kf->func)(f, u, kf);
2553 if (u != 0) {
2554 if ((short) u < 0) {
2555 error("Too few arguments for kfun %s", kf->name);
2556 } else if (u <= PROTO_NARGS(kf->proto) + PROTO_VARGS(kf->proto))
2557 {
2558 error("Bad argument %d for kfun %s", u, kf->name);
2559 } else {
2560 error("Too many arguments for kfun %s", kf->name);
2561 }
2562 }
2563 break;
2564
2565 case I_CALL_EFUNC:
2566 case I_CALL_EFUNC | I_POP_BIT:
2567 kf = &KFUN(FETCH2U(pc, u));
2568 if (PROTO_VARGS(kf->proto) != 0) {
2569 /* variable # of arguments */
2570 u = FETCH1U(pc) + size;
2571 size = 0;
2572 } else {
2573 /* fixed # of arguments */
2574 u = PROTO_NARGS(kf->proto);
2575 }
2576 if (PROTO_CLASS(kf->proto) & C_TYPECHECKED) {
2577 i_typecheck(f, (frame *) NULL, kf->name, "kfun", kf->proto, u,
2578 TRUE);
2579 }
2580 u = (*kf->func)(f, u, kf);
2581 if (u != 0) {
2582 if ((short) u < 0) {
2583 error("Too few arguments for kfun %s", kf->name);
2584 } else if (u <= PROTO_NARGS(kf->proto) + PROTO_VARGS(kf->proto))
2585 {
2586 error("Bad argument %d for kfun %s", u, kf->name);
2587 } else {
2588 error("Too many arguments for kfun %s", kf->name);
2589 }
2590 }
2591 break;
2592
2593 case I_CALL_CKFUNC:
2594 case I_CALL_CKFUNC | I_POP_BIT:
2595 kf = &KFUN(FETCH1U(pc));
2596 u = FETCH1U(pc) + size;
2597 size = 0;
2598 if (u != PROTO_NARGS(kf->proto)) {
2599 if (u < PROTO_NARGS(kf->proto)) {
2600 error("Too few arguments for kfun %s", kf->name);
2601 } else {
2602 error("Too many arguments for kfun %s", kf->name);
2603 }
2604 }
2605 if (PROTO_CLASS(kf->proto) & C_TYPECHECKED) {
2606 i_typecheck(f, (frame *) NULL, kf->name, "kfun", kf->proto, u,
2607 TRUE);
2608 }
2609 u = (*kf->func)(f, u, kf);
2610 if (u != 0) {
2611 error("Bad argument %d for kfun %s", u, kf->name);
2612 }
2613 break;
2614
2615 case I_CALL_CEFUNC:
2616 case I_CALL_CEFUNC | I_POP_BIT:
2617 kf = &KFUN(FETCH2U(pc, u));
2618 u = FETCH1U(pc) + size;
2619 size = 0;
2620 if (u != PROTO_NARGS(kf->proto)) {
2621 if (u < PROTO_NARGS(kf->proto)) {
2622 error("Too few arguments for kfun %s", kf->name);
2623 } else {
2624 error("Too many arguments for kfun %s", kf->name);
2625 }
2626 }
2627 if (PROTO_CLASS(kf->proto) & C_TYPECHECKED) {
2628 i_typecheck(f, (frame *) NULL, kf->name, "kfun", kf->proto, u,
2629 TRUE);
2630 }
2631 u = (*kf->func)(f, u, kf);
2632 if (u != 0) {
2633 error("Bad argument %d for kfun %s", u, kf->name);
2634 }
2635 break;
2636
2637 case I_CALL_AFUNC:
2638 case I_CALL_AFUNC | I_POP_BIT:
2639 u = FETCH1U(pc);
2640 i_funcall(f, (object *) NULL, (array *) NULL, 0, u,
2641 FETCH1U(pc) + size);
2642 size = 0;
2643 break;
2644
2645 case I_CALL_DFUNC:
2646 case I_CALL_DFUNC | I_POP_BIT:
2647 u = FETCH1U(pc);
2648 u2 = FETCH1U(pc);
2649 i_funcall(f, (object *) NULL, (array *) NULL,
2650 UCHAR(f->ctrl->imap[f->p_index + u]), u2,
2651 FETCH1U(pc) + size);
2652 size = 0;
2653 break;
2654
2655 case I_CALL_FUNC:
2656 case I_CALL_FUNC | I_POP_BIT:
2657 p = &f->ctrl->funcalls[2L * (f->foffset + FETCH2U(pc, u))];
2658 i_funcall(f, (object *) NULL, (array *) NULL, UCHAR(p[0]),
2659 UCHAR(p[1]), FETCH1U(pc) + size);
2660 size = 0;
2661 break;
2662
2663 case I_CATCH:
2664 case I_CATCH | I_POP_BIT:
2665 atomic = f->atomic;
2666 p = f->prog + FETCH2U(pc, u);
2667 if (!ec_push((ec_ftn) i_catcherr)) {
2668 f->atomic = FALSE;
2669 i_interpret1(f, pc);
2670 ec_pop();
2671 pc = f->pc;
2672 *--f->sp = nil_value;
2673 } else {
2674 /* error */
2675 f->pc = pc = p;
2676 PUSH_STRVAL(f, errorstr());
2677 }
2678 f->atomic = atomic;
2679 break;
2680
2681 case I_RLIMITS:
2682 if (f->sp[1].type != T_INT) {
2683 error("Bad rlimits depth type");
2684 }
2685 if (f->sp->type != T_INT) {
2686 error("Bad rlimits ticks type");
2687 }
2688 newdepth = f->sp[1].u.number;
2689 newticks = f->sp->u.number;
2690 if (!FETCH1U(pc)) {
2691 /* runtime check */
2692 i_check_rlimits(f);
2693 } else {
2694 /* pop limits */
2695 f->sp += 2;
2696 }
2697 i_new_rlimits(f, newdepth, newticks);
2698 i_interpret1(f, pc);
2699 pc = f->pc;
2700 i_set_rlimits(f, f->rlim->next);
2701 continue;
2702
2703 case I_RETURN:
2704 return;
2705
2706 # ifdef DEBUG
2707 default:
2708 fatal("illegal instruction");
2709 # endif
2710 }
2711
2712 if (instr & I_POP_BIT) {
2713 /* pop the result of the last operation (never an lvalue) */
2714 i_del_value(f->sp++);
2715 }
2716 }
2717 }
2718
2719 /*
2720 * NAME: interpret->funcall()
2721 * DESCRIPTION: Call a function in an object. The arguments must be on the
2722 * stack already.
2723 */
i_funcall(frame * prev_f,object * obj,array * lwobj,int p_ctrli,int funci,int nargs)2724 void i_funcall(frame *prev_f, object *obj, array *lwobj, int p_ctrli, int funci, int nargs)
2725 {
2726 char *pc;
2727 unsigned short n;
2728 frame f;
2729 bool ellipsis;
2730 value val;
2731
2732 f.prev = prev_f;
2733 if (prev_f->oindex == OBJ_NONE) {
2734 /*
2735 * top level call
2736 */
2737 f.oindex = obj->index;
2738 f.lwobj = (array *) NULL;
2739 f.ctrl = obj->ctrl;
2740 f.data = o_dataspace(obj);
2741 f.external = TRUE;
2742 } else if (lwobj != (array *) NULL) {
2743 /*
2744 * call_other to lightweight object
2745 */
2746 f.oindex = obj->index;
2747 f.lwobj = lwobj;
2748 f.ctrl = obj->ctrl;
2749 f.data = lwobj->primary->data;
2750 f.external = TRUE;
2751 } else if (obj != (object *) NULL) {
2752 /*
2753 * call_other to persistent object
2754 */
2755 f.oindex = obj->index;
2756 f.lwobj = (array *) NULL;
2757 f.ctrl = obj->ctrl;
2758 f.data = o_dataspace(obj);
2759 f.external = TRUE;
2760 } else {
2761 /*
2762 * local function call
2763 */
2764 f.oindex = prev_f->oindex;
2765 f.lwobj = prev_f->lwobj;
2766 f.ctrl = prev_f->ctrl;
2767 f.data = prev_f->data;
2768 f.external = FALSE;
2769 }
2770 f.depth = prev_f->depth + 1;
2771 f.rlim = prev_f->rlim;
2772 if (f.depth >= f.rlim->maxdepth && !f.rlim->nodepth) {
2773 error("Stack overflow");
2774 }
2775 if (f.rlim->ticks < 100) {
2776 if (f.rlim->noticks) {
2777 f.rlim->ticks = 0x7fffffff;
2778 } else {
2779 error("Out of ticks");
2780 }
2781 }
2782
2783 /* set the program control block */
2784 obj = OBJR(f.ctrl->inherits[p_ctrli].oindex);
2785 f.foffset = f.ctrl->inherits[p_ctrli].funcoffset;
2786 f.p_ctrl = o_control(obj);
2787 f.p_index = f.ctrl->inherits[p_ctrli].progoffset;
2788
2789 /* get the function */
2790 f.func = &d_get_funcdefs(f.p_ctrl)[funci];
2791 if (f.func->class & C_UNDEFINED) {
2792 error("Undefined function %s",
2793 d_get_strconst(f.p_ctrl, f.func->inherit, f.func->index)->text);
2794 }
2795
2796 pc = d_get_prog(f.p_ctrl) + f.func->offset;
2797 if (f.func->class & C_TYPECHECKED) {
2798 /* typecheck arguments */
2799 i_typecheck(prev_f, &f,
2800 d_get_strconst(f.p_ctrl, f.func->inherit,
2801 f.func->index)->text,
2802 "function", pc, nargs, FALSE);
2803 }
2804
2805 /* handle arguments */
2806 ellipsis = (PROTO_CLASS(pc) & C_ELLIPSIS);
2807 n = PROTO_NARGS(pc) + PROTO_VARGS(pc);
2808 if (nargs < n) {
2809 int i;
2810
2811 /* if fewer actual than formal parameters, check for varargs */
2812 if (nargs < PROTO_NARGS(pc) && stricttc) {
2813 error("Insufficient arguments for function %s",
2814 d_get_strconst(f.p_ctrl, f.func->inherit,
2815 f.func->index)->text);
2816 }
2817
2818 /* add missing arguments */
2819 i_grow_stack(prev_f, n - nargs);
2820 if (ellipsis) {
2821 --n;
2822 }
2823
2824 pc = &PROTO_FTYPE(pc);
2825 i = nargs;
2826 do {
2827 if ((FETCH1U(pc) & T_TYPE) == T_CLASS) {
2828 pc += 3;
2829 }
2830 } while (--i >= 0);
2831 while (nargs < n) {
2832 switch (i=FETCH1U(pc)) {
2833 case T_INT:
2834 *--prev_f->sp = zero_int;
2835 break;
2836
2837 case T_FLOAT:
2838 *--prev_f->sp = zero_float;
2839 break;
2840
2841 default:
2842 if ((i & T_TYPE) == T_CLASS) {
2843 pc += 3;
2844 }
2845 *--prev_f->sp = nil_value;
2846 break;
2847 }
2848 nargs++;
2849 }
2850 if (ellipsis) {
2851 PUSH_ARRVAL(prev_f, arr_new(f.data, 0));
2852 nargs++;
2853 if ((FETCH1U(pc) & T_TYPE) == T_CLASS) {
2854 pc += 3;
2855 }
2856 }
2857 } else if (ellipsis) {
2858 value *v;
2859 array *a;
2860
2861 /* put additional arguments in array */
2862 nargs -= n - 1;
2863 a = arr_new(f.data, nargs);
2864 v = a->elts + nargs;
2865 do {
2866 *--v = *prev_f->sp++;
2867 } while (--nargs > 0);
2868 d_ref_imports(a);
2869 PUSH_ARRVAL(prev_f, a);
2870 nargs = n;
2871 pc += PROTO_SIZE(pc);
2872 } else if (nargs > n) {
2873 if (stricttc) {
2874 error("Too many arguments for function %s",
2875 d_get_strconst(f.p_ctrl, f.func->inherit,
2876 f.func->index)->text);
2877 }
2878
2879 /* pop superfluous arguments */
2880 i_pop(prev_f, nargs - n);
2881 nargs = n;
2882 pc += PROTO_SIZE(pc);
2883 } else {
2884 pc += PROTO_SIZE(pc);
2885 }
2886 f.sp = prev_f->sp;
2887 f.nargs = nargs;
2888 cframe = &f;
2889 if (f.lwobj != (array *) NULL) {
2890 arr_ref(f.lwobj);
2891 }
2892
2893 /* deal with atomic functions */
2894 f.level = prev_f->level;
2895 if ((f.func->class & C_ATOMIC) && !prev_f->atomic) {
2896 o_new_plane();
2897 d_new_plane(f.data, ++f.level);
2898 f.atomic = TRUE;
2899 if (!f.rlim->noticks) {
2900 f.rlim->ticks >>= 1;
2901 }
2902 } else {
2903 if (f.level != f.data->plane->level) {
2904 d_new_plane(f.data, f.level);
2905 }
2906 f.atomic = prev_f->atomic;
2907 }
2908
2909 i_add_ticks(&f, 10);
2910
2911 /* create new local stack */
2912 f.argp = f.sp;
2913 FETCH2U(pc, n);
2914 f.stack = f.lip = ALLOCA(value, n + MIN_STACK + EXTRA_STACK);
2915 f.fp = f.sp = f.stack + n + MIN_STACK + EXTRA_STACK;
2916 f.sos = TRUE;
2917
2918 /* initialize local variables */
2919 n = FETCH1U(pc);
2920 # ifdef DEBUG
2921 nargs = n;
2922 # endif
2923 if (n > 0) {
2924 do {
2925 *--f.sp = nil_value;
2926 } while (--n > 0);
2927 }
2928
2929 /* execute code */
2930 d_get_funcalls(f.ctrl); /* make sure they are available */
2931 if (f.func->class & C_COMPILED) {
2932 Uint l;
2933
2934 /* compiled function */
2935 (*pcfunctions[FETCH3U(pc, l)])(&f);
2936 } else {
2937 /* interpreted function */
2938 f.prog = pc += 2;
2939 if (f.p_ctrl->flags & CTRL_OLDVM) {
2940 i_interpret0(&f, pc);
2941 } else {
2942 i_interpret1(&f, pc);
2943 }
2944 }
2945
2946 /* clean up stack, move return value to outer stackframe */
2947 val = *f.sp++;
2948 # ifdef DEBUG
2949 if (f.sp != f.fp - nargs || f.lip != f.stack) {
2950 fatal("bad stack pointer after function call");
2951 }
2952 # endif
2953 i_pop(&f, f.fp - f.sp);
2954 if (f.sos) {
2955 /* still alloca'd */
2956 AFREE(f.stack);
2957 } else {
2958 /* extended and malloced */
2959 FREE(f.stack);
2960 }
2961
2962 if (f.lwobj != (array *) NULL) {
2963 arr_del(f.lwobj);
2964 }
2965 cframe = prev_f;
2966 i_pop(prev_f, f.nargs);
2967 *--prev_f->sp = val;
2968
2969 if ((f.func->class & C_ATOMIC) && !prev_f->atomic) {
2970 d_commit_plane(f.level, &val);
2971 o_commit_plane();
2972 if (!f.rlim->noticks) {
2973 f.rlim->ticks *= 2;
2974 }
2975 }
2976 }
2977
2978 /*
2979 * NAME: interpret->call()
2980 * DESCRIPTION: Attempt to call a function in an object. Return TRUE if
2981 * the call succeeded.
2982 */
i_call(frame * f,object * obj,array * lwobj,char * func,unsigned int len,int call_static,int nargs)2983 bool i_call(frame *f, object *obj, array *lwobj, char *func, unsigned int len,
2984 int call_static, int nargs)
2985 {
2986 dsymbol *symb;
2987 dfuncdef *fdef;
2988 control *ctrl;
2989
2990 if (lwobj != (array *) NULL) {
2991 uindex oindex;
2992 xfloat flt;
2993 value val;
2994
2995 GET_FLT(&lwobj->elts[1], flt);
2996 if (lwobj->elts[0].type == T_OBJECT) {
2997 /*
2998 * ordinary light-weight object: upgrade first if needed
2999 */
3000 oindex = lwobj->elts[0].oindex;
3001 obj = OBJR(oindex);
3002 if (obj->update != flt.low) {
3003 d_upgrade_lwobj(lwobj, obj);
3004 }
3005 }
3006 if (flt.high != FALSE) {
3007 /*
3008 * touch the light-weight object
3009 */
3010 flt.high = FALSE;
3011 PUT_FLTVAL(&val, flt);
3012 d_assign_elt(f->data, lwobj, &lwobj->elts[1], &val);
3013 PUSH_LWOVAL(f, lwobj);
3014 PUSH_STRVAL(f, str_new(func, len));
3015 call_driver_object(f, "touch", 2);
3016 if (VAL_TRUE(f->sp)) {
3017 /* preserve through call */
3018 flt.high = TRUE;
3019 PUT_FLT(&lwobj->elts[1], flt);
3020 }
3021 i_del_value(f->sp++);
3022 }
3023 if (lwobj->elts[0].type == T_INT) {
3024 /* no user-callable functions within (right?) */
3025 i_pop(f, nargs);
3026 return FALSE;
3027 }
3028 } else if (!(obj->flags & O_TOUCHED)) {
3029 /*
3030 * initialize/touch the object
3031 */
3032 obj = OBJW(obj->index);
3033 obj->flags |= O_TOUCHED;
3034 if (O_HASDATA(obj)) {
3035 PUSH_OBJVAL(f, obj);
3036 PUSH_STRVAL(f, str_new(func, len));
3037 call_driver_object(f, "touch", 2);
3038 if (VAL_TRUE(f->sp)) {
3039 obj->flags &= ~O_TOUCHED; /* preserve though call */
3040 }
3041 i_del_value(f->sp++);
3042 } else {
3043 obj->data = d_new_dataspace(obj);
3044 if (func != (char *) NULL &&
3045 i_call(f, obj, (array *) NULL, creator, clen, TRUE, 0)) {
3046 i_del_value(f->sp++);
3047 }
3048 }
3049 }
3050 if (func == (char *) NULL) {
3051 func = creator;
3052 len = clen;
3053 }
3054
3055 /* find the function in the symbol table */
3056 ctrl = o_control(obj);
3057 symb = ctrl_symb(ctrl, func, len);
3058 if (symb == (dsymbol *) NULL) {
3059 /* function doesn't exist in symbol table */
3060 i_pop(f, nargs);
3061 return FALSE;
3062 }
3063
3064 ctrl = OBJR(ctrl->inherits[UCHAR(symb->inherit)].oindex)->ctrl;
3065 fdef = &d_get_funcdefs(ctrl)[UCHAR(symb->index)];
3066
3067 /* check if the function can be called */
3068 if (!call_static && (fdef->class & C_STATIC) &&
3069 ((lwobj != (array *) NULL) ?
3070 lwobj != f->lwobj : f->oindex != obj->index)) {
3071 i_pop(f, nargs);
3072 return FALSE;
3073 }
3074
3075 /* call the function */
3076 i_funcall(f, obj, lwobj, UCHAR(symb->inherit), UCHAR(symb->index), nargs);
3077
3078 return TRUE;
3079 }
3080
3081 /*
3082 * NAME: interpret->line0()
3083 * DESCRIPTION: return the line number the program counter of the specified
3084 * frame is at
3085 */
i_line0(frame * f)3086 static unsigned short i_line0(frame *f)
3087 {
3088 char *pc, *numbers;
3089 int instr;
3090 short offset;
3091 unsigned short line, u, sz;
3092
3093 line = 0;
3094 pc = f->p_ctrl->prog + f->func->offset;
3095 pc += PROTO_SIZE(pc) + 3;
3096 FETCH2U(pc, u);
3097 numbers = pc + u;
3098
3099 while (pc < f->pc) {
3100 instr = FETCH1U(pc);
3101
3102 offset = instr >> I_LINE_SHIFT;
3103 if (offset <= 2) {
3104 /* simple offset */
3105 line += offset;
3106 } else {
3107 offset = FETCH1U(numbers);
3108 if (offset >= 128) {
3109 /* one byte offset */
3110 line += offset - 128 - 64;
3111 } else {
3112 /* two byte offset */
3113 line += ((offset << 8) | FETCH1U(numbers)) - 16384;
3114 }
3115 }
3116
3117 switch (instr & I_INSTR_MASK) {
3118 case II_INDEX_LVAL:
3119 if ((instr & I_TYPE_BIT) && FETCH1U(pc) == T_CLASS) {
3120 pc += 3;
3121 }
3122 /* fall through */
3123 case II_PUSH_ZERO:
3124 case II_PUSH_ONE:
3125 case II_INDEX:
3126 case II_DUP:
3127 case II_STORE:
3128 case II_RETURN:
3129 break;
3130
3131 case II_PUSH_INT1:
3132 case II_PUSH_STRING:
3133 case II_PUSH_LOCAL:
3134 case II_PUSH_GLOBAL:
3135 case II_RLIMITS:
3136 pc++;
3137 break;
3138
3139 case II_CAST:
3140 if (FETCH1U(pc) == T_CLASS) {
3141 pc += 3;
3142 }
3143 break;
3144
3145 case II_PUSH_LOCAL_LVAL:
3146 case II_PUSH_GLOBAL_LVAL:
3147 case II_SPREAD:
3148 pc++;
3149 if ((instr & I_TYPE_BIT) && FETCH1U(pc) == T_CLASS) {
3150 pc += 3;
3151 }
3152 break;
3153
3154 case II_PUSH_NEAR_STRING:
3155 case II_PUSH_FAR_GLOBAL:
3156 case II_JUMP:
3157 case II_JUMP_ZERO:
3158 case II_JUMP_NONZERO:
3159 case II_CALL_AFUNC:
3160 case II_CATCH:
3161 pc += 2;
3162 break;
3163
3164 case II_PUSH_FAR_GLOBAL_LVAL:
3165 pc += 2;
3166 if ((instr & I_TYPE_BIT) && FETCH1U(pc) == T_CLASS) {
3167 pc += 3;
3168 }
3169 break;
3170
3171 case II_PUSH_FAR_STRING:
3172 case II_AGGREGATE:
3173 case II_CALL_DFUNC:
3174 case II_CALL_FUNC:
3175 pc += 3;
3176 break;
3177
3178 case II_PUSH_INT4:
3179 pc += 4;
3180 break;
3181
3182 case II_PUSH_FLOAT:
3183 pc += 6;
3184 break;
3185
3186 case II_SWITCH:
3187 switch (FETCH1U(pc)) {
3188 case 0:
3189 FETCH2U(pc, u);
3190 sz = FETCH1U(pc);
3191 pc += 2 + (u - 1) * (sz + 2);
3192 break;
3193
3194 case 1:
3195 FETCH2U(pc, u);
3196 sz = FETCH1U(pc);
3197 pc += 2 + (u - 1) * (2 * sz + 2);
3198 break;
3199
3200 case 2:
3201 FETCH2U(pc, u);
3202 pc += 2;
3203 if (FETCH1U(pc) == 0) {
3204 pc += 2;
3205 --u;
3206 }
3207 pc += (u - 1) * 5;
3208 break;
3209 }
3210 break;
3211
3212 case II_CALL_KFUNC:
3213 if (PROTO_VARGS(KFUN(FETCH1U(pc)).proto) != 0) {
3214 pc++;
3215 }
3216 break;
3217 }
3218 }
3219
3220 return line;
3221 }
3222
3223 /*
3224 * NAME: interpret->line1()
3225 * DESCRIPTION: return the line number the program counter of the specified
3226 * frame is at
3227 */
i_line1(frame * f)3228 static unsigned short i_line1(frame *f)
3229 {
3230 char *pc, *numbers;
3231 int instr;
3232 short offset;
3233 unsigned short line, u, sz;
3234
3235 line = 0;
3236 pc = f->p_ctrl->prog + f->func->offset;
3237 pc += PROTO_SIZE(pc) + 3;
3238 FETCH2U(pc, u);
3239 numbers = pc + u;
3240
3241 while (pc < f->pc) {
3242 instr = FETCH1U(pc);
3243
3244 offset = instr >> I_LINE_SHIFT;
3245 if (offset <= 2) {
3246 /* simple offset */
3247 line += offset;
3248 } else {
3249 offset = FETCH1U(numbers);
3250 if (offset >= 128) {
3251 /* one byte offset */
3252 line += offset - 128 - 64;
3253 } else {
3254 /* two byte offset */
3255 line += ((offset << 8) | FETCH1U(numbers)) - 16384;
3256 }
3257 }
3258
3259 switch (instr & I_EINSTR_MASK) {
3260 case I_INDEX:
3261 case I_INDEX | I_POP_BIT:
3262 case I_INDEX2:
3263 case I_STORE_INDEX:
3264 case I_STORE_INDEX | I_POP_BIT:
3265 case I_STORE_INDEX_INDEX:
3266 case I_STORE_INDEX_INDEX | I_POP_BIT:
3267 case I_RETURN:
3268 break;
3269
3270 case I_CALL_KFUNC:
3271 case I_CALL_KFUNC | I_POP_BIT:
3272 if (PROTO_VARGS(KFUN(FETCH1U(pc)).proto) != 0) {
3273 pc++;
3274 }
3275 break;
3276
3277 case I_PUSH_INT1:
3278 case I_PUSH_STRING:
3279 case I_PUSH_LOCAL:
3280 case I_PUSH_GLOBAL:
3281 case I_STORE_LOCAL:
3282 case I_STORE_LOCAL | I_POP_BIT:
3283 case I_STORE_GLOBAL:
3284 case I_STORE_GLOBAL | I_POP_BIT:
3285 case I_STORE_LOCAL_INDEX:
3286 case I_STORE_LOCAL_INDEX | I_POP_BIT:
3287 case I_RLIMITS:
3288 pc++;
3289 break;
3290
3291 case I_SPREAD:
3292 if (FETCH1S(pc) < 0) {
3293 break;
3294 }
3295 /* fall through */
3296 case I_CAST:
3297 case I_CAST | I_POP_BIT:
3298 if (FETCH1U(pc) == T_CLASS) {
3299 pc += 3;
3300 }
3301 break;
3302
3303 case I_CALL_EFUNC:
3304 case I_CALL_EFUNC | I_POP_BIT:
3305 if (PROTO_VARGS(KFUN(FETCH2U(pc, u)).proto) != 0) {
3306 pc++;
3307 }
3308 break;
3309
3310 case I_PUSH_INT2:
3311 case I_PUSH_NEAR_STRING:
3312 case I_PUSH_FAR_GLOBAL:
3313 case I_STORE_FAR_GLOBAL:
3314 case I_STORE_FAR_GLOBAL | I_POP_BIT:
3315 case I_STORE_GLOBAL_INDEX:
3316 case I_STORE_GLOBAL_INDEX | I_POP_BIT:
3317 case I_JUMP_ZERO:
3318 case I_JUMP_NONZERO:
3319 case I_JUMP:
3320 case I_CALL_AFUNC:
3321 case I_CALL_AFUNC | I_POP_BIT:
3322 case I_CALL_CKFUNC:
3323 case I_CALL_CKFUNC | I_POP_BIT:
3324 case I_CATCH:
3325 case I_CATCH | I_POP_BIT:
3326 pc += 2;
3327 break;
3328
3329 case I_PUSH_FAR_STRING:
3330 case I_AGGREGATE:
3331 case I_AGGREGATE | I_POP_BIT:
3332 case I_CALL_DFUNC:
3333 case I_CALL_DFUNC | I_POP_BIT:
3334 case I_CALL_FUNC:
3335 case I_CALL_FUNC | I_POP_BIT:
3336 case I_CALL_CEFUNC:
3337 case I_CALL_CEFUNC | I_POP_BIT:
3338 pc += 3;
3339 break;
3340
3341 case I_PUSH_INT4:
3342 pc += 4;
3343 break;
3344
3345 case I_PUSH_FLOAT6:
3346 pc += 6;
3347 break;
3348
3349 case I_SWITCH:
3350 switch (FETCH1U(pc)) {
3351 case 0:
3352 FETCH2U(pc, u);
3353 sz = FETCH1U(pc);
3354 pc += 2 + (u - 1) * (sz + 2);
3355 break;
3356
3357 case 1:
3358 FETCH2U(pc, u);
3359 sz = FETCH1U(pc);
3360 pc += 2 + (u - 1) * (2 * sz + 2);
3361 break;
3362
3363 case 2:
3364 FETCH2U(pc, u);
3365 pc += 2;
3366 if (FETCH1U(pc) == 0) {
3367 pc += 2;
3368 --u;
3369 }
3370 pc += (u - 1) * 5;
3371 break;
3372 }
3373 break;
3374 }
3375 }
3376
3377 return line;
3378 }
3379
3380 /*
3381 * NAME: interpret->func_trace()
3382 * DESCRIPTION: return the trace of a single function
3383 */
i_func_trace(frame * f,dataspace * data)3384 static array *i_func_trace(frame *f, dataspace *data)
3385 {
3386 char buffer[STRINGSZ + 12];
3387 value *v;
3388 string *str;
3389 char *name;
3390 unsigned short n;
3391 value *args;
3392 array *a;
3393 unsigned short max_args;
3394
3395 max_args = conf_array_size() - 5;
3396
3397 n = f->nargs;
3398 args = f->argp + n;
3399 if (n > max_args) {
3400 /* unlikely, but possible */
3401 n = max_args;
3402 }
3403 a = arr_new(data, n + 5L);
3404 v = a->elts;
3405
3406 /* object name */
3407 name = o_name(buffer, OBJR(f->oindex));
3408 if (f->lwobj == (array *) NULL) {
3409 PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 1L));
3410 v++;
3411 str->text[0] = '/';
3412 strcpy(str->text + 1, name);
3413 } else {
3414 PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 4L));
3415 v++;
3416 str->text[0] = '/';
3417 strcpy(str->text + 1, name);
3418 strcpy(str->text + str->len - 3, "#-1");
3419 }
3420
3421 /* program name */
3422 name = OBJR(f->p_ctrl->oindex)->chain.name;
3423 PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 1L));
3424 v++;
3425 str->text[0] = '/';
3426 strcpy(str->text + 1, name);
3427
3428 /* function name */
3429 PUT_STRVAL(v, d_get_strconst(f->p_ctrl, f->func->inherit, f->func->index));
3430 v++;
3431
3432 /* line number */
3433 PUT_INTVAL(v, (f->func->class & C_COMPILED) ? 0 :
3434 (f->p_ctrl->flags & CTRL_OLDVM) ? i_line0(f) : i_line1(f));
3435 v++;
3436
3437 /* external flag */
3438 PUT_INTVAL(v, f->external);
3439 v++;
3440
3441 /* arguments */
3442 while (n > 0) {
3443 *v++ = *--args;
3444 i_ref_value(args);
3445 --n;
3446 }
3447 d_ref_imports(a);
3448
3449 return a;
3450 }
3451
3452 /*
3453 * NAME: interpret->call_tracei()
3454 * DESCRIPTION: get the trace of a single function
3455 */
i_call_tracei(frame * ftop,Int idx,value * v)3456 bool i_call_tracei(frame *ftop, Int idx, value *v)
3457 {
3458 frame *f;
3459 unsigned short n;
3460
3461 for (f = ftop, n = 0; f->oindex != OBJ_NONE; f = f->prev, n++) ;
3462 if (idx < 0 || idx >= n) {
3463 return FALSE;
3464 }
3465
3466 for (f = ftop, n -= idx + 1; n != 0; f = f->prev, --n) ;
3467 PUT_ARRVAL(v, i_func_trace(f, ftop->data));
3468 return TRUE;
3469 }
3470
3471 /*
3472 * NAME: interpret->call_trace()
3473 * DESCRIPTION: return the function call trace
3474 */
i_call_trace(frame * ftop)3475 array *i_call_trace(frame *ftop)
3476 {
3477 frame *f;
3478 value *v;
3479 unsigned short n;
3480 array *a;
3481
3482 for (f = ftop, n = 0; f->oindex != OBJ_NONE; f = f->prev, n++) ;
3483 a = arr_new(ftop->data, (long) n);
3484 i_add_ticks(ftop, 10 * n);
3485 for (f = ftop, v = a->elts + n; f->oindex != OBJ_NONE; f = f->prev) {
3486 --v;
3487 PUT_ARRVAL(v, i_func_trace(f, ftop->data));
3488 }
3489
3490 return a;
3491 }
3492
3493 /*
3494 * NAME: emptyhandler()
3495 * DESCRIPTION: fake error handler
3496 */
emptyhandler(frame * f,Int depth)3497 static void emptyhandler(frame *f, Int depth)
3498 {
3499 UNREFERENCED_PARAMETER(f);
3500 UNREFERENCED_PARAMETER(depth);
3501 }
3502
3503 /*
3504 * NAME: interpret->call_critical()
3505 * DESCRIPTION: Call a function in the driver object at a critical moment.
3506 * The function is called with rlimits (-1; -1) and errors
3507 * caught.
3508 */
i_call_critical(frame * f,char * func,int narg,int flag)3509 bool i_call_critical(frame *f, char *func, int narg, int flag)
3510 {
3511 bool ok;
3512
3513 i_new_rlimits(f, -1, -1);
3514 f->sp += narg; /* so the error context knows what to pop */
3515 if (ec_push((flag) ? (ec_ftn) NULL : (ec_ftn) emptyhandler)) {
3516 ok = FALSE;
3517 } else {
3518 f->sp -= narg; /* recover arguments */
3519 call_driver_object(f, func, narg);
3520 ec_pop();
3521 ok = TRUE;
3522 }
3523 i_set_rlimits(f, f->rlim->next);
3524
3525 return ok;
3526 }
3527
3528 /*
3529 * NAME: interpret->runtime_error()
3530 * DESCRIPTION: handle a runtime error
3531 */
i_runtime_error(frame * f,Int depth)3532 void i_runtime_error(frame *f, Int depth)
3533 {
3534 PUSH_STRVAL(f, errorstr());
3535 PUSH_INTVAL(f, depth);
3536 PUSH_INTVAL(f, i_get_ticks(f));
3537 if (!i_call_critical(f, "runtime_error", 3, FALSE)) {
3538 message("Error within runtime_error:\012"); /* LF */
3539 message((char *) NULL);
3540 } else {
3541 i_del_value(f->sp++);
3542 }
3543 }
3544
3545 /*
3546 * NAME: interpret->atomic_error()
3547 * DESCRIPTION: handle error in atomic code
3548 */
i_atomic_error(frame * ftop,Int level)3549 void i_atomic_error(frame *ftop, Int level)
3550 {
3551 frame *f;
3552
3553 for (f = ftop; f->level != level; f = f->prev) ;
3554
3555 PUSH_STRVAL(ftop, errorstr());
3556 PUSH_INTVAL(ftop, f->depth);
3557 PUSH_INTVAL(ftop, i_get_ticks(ftop));
3558 if (!i_call_critical(ftop, "atomic_error", 3, FALSE)) {
3559 message("Error within atomic_error:\012"); /* LF */
3560 message((char *) NULL);
3561 } else {
3562 i_del_value(ftop->sp++);
3563 }
3564 }
3565
3566 /*
3567 * NAME: interpret->restore()
3568 * DESCRIPTION: restore state to given level
3569 */
i_restore(frame * ftop,Int level)3570 frame *i_restore(frame *ftop, Int level)
3571 {
3572 frame *f;
3573
3574 for (f = ftop; f->level != level; f = f->prev) ;
3575
3576 if (f->rlim != ftop->rlim) {
3577 i_set_rlimits(ftop, f->rlim);
3578 }
3579 if (!f->rlim->noticks) {
3580 f->rlim->ticks *= 2;
3581 }
3582 i_set_sp(ftop, f->sp);
3583 d_discard_plane(ftop->level);
3584 o_discard_plane();
3585
3586 return f;
3587 }
3588
3589 /*
3590 * NAME: interpret->clear()
3591 * DESCRIPTION: clean up the interpreter state
3592 */
i_clear()3593 void i_clear()
3594 {
3595 frame *f;
3596
3597 f = cframe;
3598 if (f->stack != stack) {
3599 FREE(f->stack);
3600 f->fp = f->sp = stack + MIN_STACK;
3601 f->stack = f->lip = stack;
3602 }
3603
3604 f->rlim = &rlim;
3605 }
3606