|
|
1 # include "dgd.h"
2 # include "str.h"
3 # include "array.h"
4 # include "object.h"
5 # include "xfloat.h"
6 # include "interpret.h"
7 # include "data.h"
8 # include "control.h"
9 # include "csupport.h"
10 # include "table.h"
11
12 # ifdef DEBUG
13 # undef EXTRA_STACK
14 # define EXTRA_STACK 0
15 # endif
16
17
18 static value stack[MIN_STACK]; /* initial stack */
19 static frame topframe; /* top frame */
20 static rlinfo rlim; /* top rlimits info */
21 frame *cframe; /* current frame */
22 static char *creator; /* creator function name */
23 static unsigned int clen; /* creator function name length */
24 static bool stricttc; /* strict typechecking */
25
26 int nil_type; /* type of nil value */
27 value zero_int = { T_INT, TRUE };
28 value zero_float = { T_FLOAT, TRUE };
29 value nil_value = { T_NIL, TRUE };
30
31 /*
32 * NAME: interpret->init()
33 * DESCRIPTION: initialize the interpreter
34 */
35 void i_init(create, flag)
36 char *create;
37 int flag;
38 {
39 topframe.oindex = OBJ_NONE;
40 topframe.fp = topframe.sp = stack + MIN_STACK;
41 topframe.stack = topframe.lip = stack;
42 rlim.nodepth = TRUE;
43 rlim.noticks = TRUE;
44 topframe.rlim = &rlim;
45 topframe.level = 0;
46 topframe.atomic = FALSE;
47 cframe = &topframe;
48
49 creator = create;
50 clen = strlen(create);
51 stricttc = flag;
52
53 nil_value.type = nil_type = (stricttc) ? T_NIL : T_INT;
54 }
55
56 /*
57 * NAME: interpret->ref_value()
58 * DESCRIPTION: reference a value
59 */
60 void i_ref_value(v)
61 register value *v;
62 {
63 switch (v->type) {
64 case T_STRING:
65 str_ref(v->u.string);
66 break;
67
68 case T_ARRAY:
69 case T_MAPPING:
70 arr_ref(v->u.array);
71 break;
72 }
73 }
74
75 /*
76 * NAME: interpret->del_value()
77 * DESCRIPTION: dereference a value (not an lvalue)
78 */
79 void i_del_value(v)
80 register value *v;
81 {
82 switch (v->type) {
83 case T_STRING:
84 str_del(v->u.string);
85 break;
86
87 case T_ARRAY:
88 case T_MAPPING:
89 arr_del(v->u.array);
90 break;
91 }
92 }
93
94 /*
95 * NAME: interpret->copy()
96 * DESCRIPTION: copy values from one place to another
97 */
98 void i_copy(v, w, len)
99 register value *v, *w;
100 register unsigned int len;
101 {
102 for ( ; len != 0; --len) {
103 switch (w->type) {
104 case T_STRING:
105 str_ref(w->u.string);
106 break;
107
108 case T_OBJECT:
109 if (DESTRUCTED(w)) {
110 *v++ = nil_value;
111 w++;
112 continue;
113 }
114 break;
115
116 case T_ARRAY:
117 case T_MAPPING:
118 arr_ref(w->u.array);
119 break;
120 }
121 *v++ = *w++;
122 }
123 }
124
125 /*
126 * NAME: interpret->grow_stack()
127 * DESCRIPTION: check if there is room on the stack for new values; if not,
128 * make space
129 */
130 void i_grow_stack(f, size)
131 register frame *f;
132 int size;
133 {
134 if (f->sp < f->lip + size + MIN_STACK) {
135 register int spsize, lisize;
136 register value *v, *stk;
137 register long offset;
138
139 /*
140 * extend the local stack
141 */
142 spsize = f->fp - f->sp;
143 lisize = f->lip - f->stack;
144 size = ALGN(spsize + lisize + size + MIN_STACK, 8);
145 stk = ALLOC(value, size);
146 offset = (long) (stk + size) - (long) f->fp;
147
148 /* move lvalue index stack values */
149 if (lisize != 0) {
150 memcpy(stk, f->stack, lisize * sizeof(value));
151 }
152 f->lip = stk + lisize;
153
154 /* move stack values */
155 v = stk + size;
156 if (spsize != 0) {
157 memcpy(v - spsize, f->sp, spsize * sizeof(value));
158 do {
159 --v;
160 if ((v->type == T_LVALUE || v->type == T_SLVALUE) &&
161 v->u.lval >= f->sp && v->u.lval < f->fp) {
162 v->u.lval = (value *) ((long) v->u.lval + offset);
163 }
164 } while (--spsize > 0);
165 }
166 f->sp = v;
167
168 /* replace old stack */
169 if (f->sos) {
170 /* stack on stack: alloca'd */
171 AFREE(f->stack);
172 f->sos = FALSE;
173 } else if (f->stack != stack) {
174 FREE(f->stack);
175 }
176 f->stack = stk;
177 f->fp = stk + size;
178 }
179 }
180
181 /*
182 * NAME: interpret->push_value()
183 * DESCRIPTION: push a value on the stack
184 */
185 void i_push_value(f, v)
186 frame *f;
187 register value *v;
188 {
189 *--f->sp = *v;
190 switch (v->type) {
191 case T_STRING:
192 str_ref(v->u.string);
193 break;
194
195 case T_OBJECT:
196 if (DESTRUCTED(v)) {
197 /*
198 * can't wipe out the original, since it may be a value from a
199 * mapping
200 */
201 *f->sp = nil_value;
202 }
203 break;
204
205 case T_ARRAY:
206 case T_MAPPING:
207 arr_ref(v->u.array);
208 break;
209 }
210 }
211
212 /*
213 * NAME: interpret->pop()
214 * DESCRIPTION: pop a number of values (can be lvalues) from the stack
215 */
216 void i_pop(f, n)
217 register frame *f;
218 register int n;
219 {
220 register value *v;
221
222 for (v = f->sp; --n >= 0; v++) {
223 switch (v->type) {
224 case T_STRING:
225 str_del(v->u.string);
226 break;
227
228 case T_ALVALUE:
229 --f->lip;
230 case T_ARRAY:
231 case T_MAPPING:
232 arr_del(v->u.array);
233 break;
234
235 case T_SLVALUE:
236 --f->lip;
237 break;
238
239 case T_MLVALUE:
240 i_del_value(--f->lip);
241 arr_del(v->u.array);
242 break;
243
244 case T_SALVALUE:
245 f->lip -= 2;
246 arr_del(v->u.array);
247 break;
248
249 case T_SMLVALUE:
250 f->lip -= 2;
251 i_del_value(f->lip);
252 arr_del(v->u.array);
253 break;
254 }
255 }
256 f->sp = v;
257 }
258
259 /*
260 * NAME: interpret->reverse()
261 * DESCRIPTION: reverse the order of arguments on the stack
262 */
263 void i_reverse(f, n)
264 frame *f;
265 register int n;
266 {
267 value sp[MAX_LOCALS];
268 value lip[MAX_LOCALS];
269 register value *v1, *v2, *w1, *w2;
270
271 if (n > 1) {
272 /*
273 * more than one argument
274 */
275 v1 = f->sp;
276 v2 = sp;
277 w1 = lip;
278 w2 = f->lip;
279 memcpy(v2, v1, n * sizeof(value));
280 v1 += n;
281
282 do {
283 switch (v2->type) {
284 case T_SLVALUE:
285 case T_ALVALUE:
286 case T_MLVALUE:
287 *w1++ = *--w2;
288 break;
289
290 case T_SALVALUE:
291 case T_SMLVALUE:
292 w2 -= 2;
293 *w1++ = w2[0];
294 *w1++ = w2[1];
295 break;
296 }
297
298 *--v1 = *v2++;
299 } while (--n != 0);
300
301 /*
302 * copy back lvalue indices, if needed
303 */
304 n = f->lip - w2;
305 if (n > 1) {
306 memcpy(w2, lip, n * sizeof(value));
307 }
308 }
309 }
310
311 /*
312 * NAME: interpret->odest()
313 * DESCRIPTION: replace all occurrances of an object on the stack by nil
314 */
315 void i_odest(prev, obj)
316 register frame *prev;
317 object *obj;
318 {
319 register frame *f;
320 register Uint count;
321 register value *v;
322 register unsigned short n;
323
324 count = obj->count;
325
326 /* wipe out objects in stack frames */
327 for (;;) {
328 f = prev;
329 for (v = f->sp; v < f->fp; v++) {
330 if (v->type == T_OBJECT && v->u.objcnt == count) {
331 *v = nil_value;
332 }
333 }
334 for (v = f->lip; --v >= f->stack; ) {
335 if (v->type == T_OBJECT && v->u.objcnt == count) {
336 *v = nil_value;
337 }
338 }
339
340 prev = f->prev;
341 if (prev == (frame *) NULL) {
342 break;
343 }
344 if ((f->func->class & C_ATOMIC) && !prev->atomic) {
345 /*
346 * wipe out objects in arguments to atomic function call
347 */
348 for (n = f->nargs, v = prev->sp; n != 0; --n, v++) {
349 if (v->type == T_OBJECT && v->u.objcnt == count) {
350 *v = nil_value;
351 }
352 }
353 break;
354 }
355 }
356 }
357
358 /*
359 * NAME: interpret->string()
360 * DESCRIPTION: push a string constant on the stack
361 */
362 void i_string(f, inherit, index)
363 frame *f;
364 int inherit;
365 unsigned int index;
366 {
367 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, inherit, index));
368 }
369
370 /*
371 * NAME: interpret->aggregate()
372 * DESCRIPTION: create an array on the stack
373 */
374 void i_aggregate(f, size)
375 register frame *f;
376 register unsigned int size;
377 {
378 register array *a;
379
380 if (size == 0) {
381 a = arr_new(f->data, 0L);
382 } else {
383 register value *v, *elts;
384
385 i_add_ticks(f, size);
386 a = arr_new(f->data, (long) size);
387 elts = a->elts + size;
388 v = f->sp;
389 do {
390 *--elts = *v++;
391 } while (--size != 0);
392 d_ref_imports(a);
393 f->sp = v;
394 }
395 PUSH_ARRVAL(f, a);
396 }
397
398 /*
399 * NAME: interpret->map_aggregate()
400 * DESCRIPTION: create a mapping on the stack
401 */
402 void i_map_aggregate(f, size)
403 register frame *f;
404 register unsigned int size;
405 {
406 register array *a;
407
408 if (size == 0) {
409 a = map_new(f->data, 0L);
410 } else {
411 register value *v, *elts;
412
413 i_add_ticks(f, size);
414 a = map_new(f->data, (long) size);
415 elts = a->elts + size;
416 v = f->sp;
417 do {
418 *--elts = *v++;
419 } while (--size != 0);
420 f->sp = v;
421 if (ec_push((ec_ftn) NULL)) {
422 /* error in sorting, delete mapping and pass on error */
423 arr_ref(a);
424 arr_del(a);
425 error((char *) NULL);
426 }
427 map_sort(a);
428 ec_pop();
429 d_ref_imports(a);
430 }
431 PUSH_MAPVAL(f, a);
432 }
433
434 /*
435 * NAME: interpret->spread()
436 * DESCRIPTION: push the values in an array on the stack, return the size
437 * of the array - 1
438 */
439 int i_spread(f, n, vtype)
440 register frame *f;
441 register int n, vtype;
442 {
443 register array *a;
444 register int i;
445 register value *v;
446
447 if (f->sp->type != T_ARRAY) {
448 error("Spread of non-array");
449 }
450 a = f->sp->u.array;
451 if (n < 0 || n > a->size) {
452 /* no lvalues */
453 n = a->size;
454 }
455 if (a->size > 0) {
456 i_add_ticks(f, a->size);
457 i_grow_stack(f, (a->size << 1) - n - 1);
458 a->ref += a->size - n;
459 }
460 f->sp++;
461
462 /* values */
463 for (i = 0, v = d_get_elts(a); i < n; i++, v++) {
464 i_push_value(f, v);
465 }
466 /* lvalues */
467 for (n = a->size; i < n; i++) {
468 (--f->sp)->type = T_ALVALUE;
469 f->sp->oindex = vtype;
470 f->sp->u.array = a;
471 f->lip->type = T_INT;
472 (f->lip++)->u.number = i;
473 }
474
475 arr_del(a);
476 return n - 1;
477 }
478
479 /*
480 * NAME: interpret->global()
481 * DESCRIPTION: push a global value on the stack
482 */
483 void i_global(f, inherit, index)
484 register frame *f;
485 register int inherit, index;
486 {
487 i_add_ticks(f, 4);
488 if (inherit != 0) {
489 inherit = f->ctrl->inherits[f->p_index - inherit].varoffset;
490 }
491 i_push_value(f, d_get_variable(f->data, inherit + index));
492 }
493
494 /*
495 * NAME: interpret->global_lvalue()
496 * DESCRIPTION: push a global lvalue on the stack
497 */
498 void i_global_lvalue(f, inherit, index, vtype)
499 register frame *f;
500 register int inherit;
501 int index, vtype;
502 {
503 i_add_ticks(f, 4);
504 if (inherit != 0) {
505 inherit = f->ctrl->inherits[f->p_index - inherit].varoffset;
506 }
507 (--f->sp)->type = T_LVALUE;
508 f->sp->oindex = vtype;
509 f->sp->u.lval = d_get_variable(f->data, inherit + index);
510 }
511
512 /*
513 * NAME: interpret->index()
514 * DESCRIPTION: index a value, REPLACING it with the indexed value
515 */
516 void i_index(f)
517 register frame *f;
518 {
519 register int i;
520 register value *aval, *ival, *val;
521 array *a;
522
523 i_add_ticks(f, 2);
524 ival = f->sp++;
525 aval = f->sp;
526 switch (aval->type) {
527 case T_STRING:
528 if (ival->type != T_INT) {
529 i_del_value(ival);
530 error("Non-numeric string index");
531 }
532 i = UCHAR(aval->u.string->text[str_index(aval->u.string,
533 (long) ival->u.number)]);
534 str_del(aval->u.string);
535 PUT_INTVAL(aval, i);
536 return;
537
538 case T_ARRAY:
539 if (ival->type != T_INT) {
540 i_del_value(ival);
541 error("Non-numeric array index");
542 }
543 val = &d_get_elts(aval->u.array)[arr_index(aval->u.array,
544 (long) ival->u.number)];
545 break;
546
547 case T_MAPPING:
548 val = map_index(f->data, aval->u.array, ival, (value *) NULL);
549 i_del_value(ival);
550 break;
551
552 default:
553 i_del_value(ival);
554 error("Index on bad type");
555 }
556
557 a = aval->u.array;
558 switch (val->type) {
559 case T_STRING:
560 str_ref(val->u.string);
561 break;
562
563 case T_OBJECT:
564 if (DESTRUCTED(val)) {
565 val = &nil_value;
566 }
567 break;
568
569 case T_ARRAY:
570 case T_MAPPING:
571 arr_ref(val->u.array);
572 break;
573 }
574 *aval = *val;
575 arr_del(a);
576 }
577
578 /*
579 * NAME: interpret->index_lvalue()
580 * DESCRIPTION: Index a value, REPLACING it by an indexed lvalue.
581 */
582 void i_index_lvalue(f, vtype)
583 register frame *f;
584 int vtype;
585 {
586 register int i;
587 register value *lval, *ival, *val;
588
589 i_add_ticks(f, 2);
590 ival = f->sp++;
591 lval = f->sp;
592 switch (lval->type) {
593 case T_STRING:
594 /* for instance, "foo"[1] = 'a'; */
595 i_del_value(ival);
596 error("Bad lvalue");
597
598 case T_ARRAY:
599 if (ival->type != T_INT) {
600 i_del_value(ival);
601 error("Non-numeric array index");
602 }
603 i = arr_index(lval->u.array, (long) ival->u.number);
604 lval->type = T_ALVALUE;
605 lval->oindex = vtype;
606 f->lip->type = T_INT;
607 (f->lip++)->u.number = i;
608 return;
609
610 case T_MAPPING:
611 lval->type = T_MLVALUE;
612 lval->oindex = vtype;
613 *f->lip++ = *ival;
614 return;
615
616 case T_LVALUE:
617 /*
618 * note: the lvalue is not yet referenced
619 */
620 switch (lval->u.lval->type) {
621 case T_STRING:
622 if (ival->type != T_INT) {
623 i_del_value(ival);
624 error("Non-numeric string index");
625 }
626 i = str_index(f->lvstr = lval->u.lval->u.string,
627 (long) ival->u.number);
628 /* indexed string lvalues are not referenced */
629 lval->type = T_SLVALUE;
630 lval->oindex = vtype;
631 f->lip->type = T_INT;
632 (f->lip++)->u.number = i;
633 return;
634
635 case T_ARRAY:
636 if (ival->type != T_INT) {
637 i_del_value(ival);
638 error("Non-numeric array index");
639 }
640 i = arr_index(lval->u.lval->u.array, (long) ival->u.number);
641 lval->type = T_ALVALUE;
642 lval->oindex = vtype;
643 arr_ref(lval->u.array = lval->u.lval->u.array);
644 f->lip->type = T_INT;
645 (f->lip++)->u.number = i;
646 return;
647
648 case T_MAPPING:
649 lval->type = T_MLVALUE;
650 lval->oindex = vtype;
651 arr_ref(lval->u.array = lval->u.lval->u.array);
652 *f->lip++ = *ival;
653 return;
654 }
655 break;
656
657 case T_ALVALUE:
658 val = &d_get_elts(lval->u.array)[f->lip[-1].u.number];
659 switch (val->type) {
660 case T_STRING:
661 if (ival->type != T_INT) {
662 i_del_value(ival);
663 error("Non-numeric string index");
664 }
665 i = str_index(f->lvstr = val->u.string, (long) ival->u.number);
666 lval->type = T_SALVALUE;
667 lval->oindex = vtype;
668 f->lip->type = T_INT;
669 (f->lip++)->u.number = i;
670 return;
671
672 case T_ARRAY:
673 if (ival->type != T_INT) {
674 i_del_value(ival);
675 error("Non-numeric array index");
676 }
677 i = arr_index(val->u.array, (long) ival->u.number);
678 arr_ref(val->u.array); /* has to be first */
679 arr_del(lval->u.array); /* has to be second */
680 lval->oindex = vtype;
681 lval->u.array = val->u.array;
682 f->lip[-1].u.number = i;
683 return;
684
685 case T_MAPPING:
686 arr_ref(val->u.array); /* has to be first */
687 arr_del(lval->u.array); /* has to be second */
688 lval->type = T_MLVALUE;
689 lval->oindex = vtype;
690 lval->u.array = val->u.array;
691 f->lip[-1] = *ival;
692 return;
693 }
694 break;
695
696 case T_MLVALUE:
697 val = map_index(f->data, lval->u.array, &f->lip[-1], (value *) NULL);
698 switch (val->type) {
699 case T_STRING:
700 if (ival->type != T_INT) {
701 i_del_value(ival);
702 error("Non-numeric string index");
703 }
704 i = str_index(f->lvstr = val->u.string, (long) ival->u.number);
705 lval->type = T_SMLVALUE;
706 lval->oindex = vtype;
707 f->lip->type = T_INT;
708 (f->lip++)->u.number = i;
709 return;
710
711 case T_ARRAY:
712 if (ival->type != T_INT) {
713 i_del_value(ival);
714 error("Non-numeric array index");
715 }
716 i = arr_index(val->u.array, (long) ival->u.number);
717 arr_ref(val->u.array); /* has to be first */
718 arr_del(lval->u.array); /* has to be second */
719 lval->type = T_ALVALUE;
720 lval->oindex = vtype;
721 lval->u.array = val->u.array;
722 i_del_value(&f->lip[-1]);
723 f->lip[-1].type = T_INT;
724 f->lip[-1].u.number = i;
725 return;
726
727 case T_MAPPING:
728 arr_ref(val->u.array); /* has to be first */
729 arr_del(lval->u.array); /* has to be second */
730 lval->oindex = vtype;
731 lval->u.array = val->u.array;
732 i_del_value(&f->lip[-1]);
733 f->lip[-1] = *ival;
734 return;
735 }
736 break;
737 }
738 i_del_value(ival);
739 error("Index on bad type");
740 }
741
742 /*
743 * NAME: interpret->typename()
744 * DESCRIPTION: return the name of the argument type
745 */
746 char *i_typename(buf, type)
747 register char *buf;
748 register unsigned int type;
749 {
750 static char *name[] = TYPENAMES;
751
752 strcpy(buf, name[type & T_TYPE]);
753 type &= T_REF;
754 type >>= REFSHIFT;
755 if (type > 0) {
756 register char *p;
757
758 p = buf + strlen(buf);
759 *p++ = ' ';
760 do {
761 *p++ = '*';
762 } while (--type > 0);
763 *p = '\0';
764 }
765 return buf;
766 }
767
768 /*
769 * NAME: interpret->cast()
770 * DESCRIPTION: cast a value to a type
771 */
772 void i_cast(val, type)
773 register value *val;
774 register unsigned int type;
775 {
776 char tnbuf[8];
777
778 if (val->type != type && (!VAL_NIL(val) || !T_POINTER(type))) {
779 i_typename(tnbuf, type);
780 if (strchr("aeiuoy", tnbuf[0]) != (char *) NULL) {
781 error("Value is not an %s", tnbuf);
782 } else {
783 error("Value is not a %s", tnbuf);
784 }
785 }
786 }
787
788 /*
789 * NAME: interpret->fetch()
790 * DESCRIPTION: fetch the value of an lvalue
791 */
792 void i_fetch(f)
793 register frame *f;
794 {
795 switch (f->sp->type) {
796 case T_LVALUE:
797 i_push_value(f, f->sp->u.lval);
798 break;
799
800 case T_ALVALUE:
801 i_push_value(f, d_get_elts(f->sp->u.array) + f->lip[-1].u.number);
802 break;
803
804 case T_MLVALUE:
805 i_push_value(f, map_index(f->data, f->sp->u.array, &f->lip[-1],
806 (value *) NULL));
807 break;
808
809 default:
810 /*
811 * Indexed string.
812 * The fetch is always done directly after an lvalue
813 * constructor, so lvstr is valid.
814 */
815 PUSH_INTVAL(f, UCHAR(f->lvstr->text[f->lip[-1].u.number]));
816 break;
817 }
818 }
819
820 /*
821 * NAME: istr()
822 * DESCRIPTION: create a copy of the argument string, with one char replaced
823 */
824 static value *istr(val, str, i, v)
825 register value *val, *v;
826 register string *str;
827 ssizet i;
828 {
829 if (v->type != T_INT) {
830 error("Non-numeric value in indexed string assignment");
831 }
832
833 PUT_STRVAL_NOREF(val, (str->primary == (strref *) NULL && str->ref == 1) ?
834 str : str_new(str->text, (long) str->len));
835 val->u.string->text[i] = v->u.number;
836 return val;
837 }
838
839 /*
840 * NAME: interpret->store()
841 * DESCRIPTION: Perform an assignment. This invalidates the lvalue.
842 */
843 void i_store(f)
844 register frame *f;
845 {
846 value ival;
847 register value *lval, *val, *v;
848 register ssizet i;
849 register array *a;
850
851 lval = f->sp + 1;
852 val = f->sp;
853 if (lval->oindex != 0) {
854 i_cast(val, lval->oindex);
855 }
856
857 i_add_ticks(f, 1);
858 switch (lval->type) {
859 case T_LVALUE:
860 d_assign_var(f->data, lval->u.lval, val);
861 break;
862
863 case T_SLVALUE:
864 v = lval->u.lval;
865 i = f->lip[-1].u.number;
866 if (v->type != T_STRING || i >= v->u.string->len) {
867 /*
868 * The lvalue was changed.
869 */
870 error("Lvalue disappeared!");
871 }
872 --f->lip;
873 d_assign_var(f->data, v, istr(&ival, v->u.string, i, val));
874 break;
875
876 case T_ALVALUE:
877 a = lval->u.array;
878 d_assign_elt(f->data, a, &d_get_elts(a)[(--f->lip)->u.number], val);
879 arr_del(a);
880 break;
881
882 case T_MLVALUE:
883 map_index(f->data, a = lval->u.array, &f->lip[-1], val);
884 i_del_value(--f->lip);
885 arr_del(a);
886 break;
887
888 case T_SALVALUE:
889 a = lval->u.array;
890 v = &a->elts[f->lip[-2].u.number];
891 i = f->lip[-1].u.number;
892 if (v->type != T_STRING || i >= v->u.string->len) {
893 /*
894 * The lvalue was changed.
895 */
896 error("Lvalue disappeared!");
897 }
898 d_assign_elt(f->data, a, v, istr(&ival, v->u.string, i, val));
899 f->lip -= 2;
900 arr_del(a);
901 break;
902
903 case T_SMLVALUE:
904 a = lval->u.array;
905 v = map_index(f->data, a, &f->lip[-2], (value *) NULL);
906 i = f->lip[-1].u.number;
907 if (v->type != T_STRING || i >= v->u.string->len) {
908 /*
909 * The lvalue was changed.
910 */
911 error("Lvalue disappeared!");
912 }
913 d_assign_elt(f->data, a, v, istr(&ival, v->u.string, i, val));
914 f->lip -= 2;
915 i_del_value(f->lip);
916 arr_del(a);
917 break;
918 }
919 }
920
921 /*
922 * NAME: interpret->get_depth()
923 * DESCRIPTION: get the remaining stack depth (-1: infinite)
924 */
925 Int i_get_depth(f)
926 frame *f;
927 {
928 register rlinfo *rlim;
929
930 rlim = f->rlim;
931 if (rlim->nodepth) {
932 return -1;
933 }
934 return rlim->maxdepth - f->depth;
935 }
936
937 /*
938 * NAME: interpret->get_ticks()
939 * DESCRIPTION: get the remaining ticks (-1: infinite)
940 */
941 Int i_get_ticks(f)
942 frame *f;
943 {
944 register rlinfo *rlim;
945
946 rlim = f->rlim;
947 if (rlim->noticks) {
948 return -1;
949 } else {
950 return (rlim->ticks < 0) ? 0 : rlim->ticks << f->level;
951 }
952 }
953
954 /*
955 * NAME: interpret->check_rlimits()
956 * DESCRIPTION: check if this rlimits call is valid
957 */
958 static void i_check_rlimits(f)
959 register frame *f;
960 {
961 object *obj;
962
963 obj = OBJR(f->oindex);
964 if (obj->count == 0) {
965 error("Illegal use of rlimits");
966 }
967 --f->sp;
968 f->sp[0] = f->sp[1];
969 f->sp[1] = f->sp[2];
970 PUT_OBJVAL(&f->sp[2], obj);
971 /* obj, stack, ticks */
972 call_driver_object(f, "runtime_rlimits", 3);
973
974 if (!VAL_TRUE(f->sp)) {
975 error("Illegal use of rlimits");
976 }
977 i_del_value(f->sp++);
978 }
979
980 /*
981 * NAME: interpret->new_rlimits()
982 * DESCRIPTION: create new rlimits scope
983 */
984 void i_new_rlimits(f, depth, t)
985 register frame *f;
986 Int depth, t;
987 {
988 register rlinfo *rlim;
989
990 rlim = ALLOC(rlinfo, 1);
991 if (depth != 0) {
992 if (depth < 0) {
993 rlim->nodepth = TRUE;
994 } else {
995 rlim->maxdepth = f->depth + depth;
996 rlim->nodepth = FALSE;
997 }
998 } else {
999 rlim->maxdepth = f->rlim->maxdepth;
1000 rlim->nodepth = f->rlim->nodepth;
1001 }
1002 if (t != 0) {
1003 if (t < 0) {
1004 rlim->noticks = TRUE;
1005 } else {
1006 t >>= f->level;
1007 f->rlim->ticks -= t;
1008 rlim->ticks = t;
1009 rlim->noticks = FALSE;
1010 }
1011 } else {
1012 f->rlim->ticks = 0;
1013 rlim->ticks = f->rlim->ticks;
1014 rlim->noticks = f->rlim->noticks;
1015 }
1016
1017 rlim->next = f->rlim;
1018 f->rlim = rlim;
1019 }
1020
1021 /*
1022 * NAME: interpret->set_rlimits()
1023 * DESCRIPTION: restore rlimits to an earlier state
1024 */
1025 void i_set_rlimits(f, rlim)
1026 frame *f;
1027 register rlinfo *rlim;
1028 {
1029 register rlinfo *r, *next;
1030
1031 r = f->rlim;
1032 if (r->ticks < 0) {
1033 r->ticks = 0;
1034 }
1035 while (r != rlim) {
1036 next = r->next;
1037 if (!r->noticks) {
1038 next->ticks += r->ticks;
1039 }
1040 FREE(r);
1041 r = next;
1042 }
1043 f->rlim = rlim;
1044 }
1045
1046 /*
1047 * NAME: interpret->set_sp()
1048 * DESCRIPTION: set the current stack pointer
1049 */
1050 frame *i_set_sp(ftop, sp)
1051 frame *ftop;
1052 register value *sp;
1053 {
1054 register value *v, *w;
1055 register frame *f;
1056
1057 for (f = ftop; f != (frame *) NULL; f = f->prev) {
1058 v = f->sp;
1059 w = f->lip;
1060 for (;;) {
1061 if (v == sp) {
1062 f->sp = v;
1063 f->lip = w;
1064 return f;
1065 }
1066 if (v == f->fp) {
1067 break;
1068 }
1069 switch (v->type) {
1070 case T_STRING:
1071 str_del(v->u.string);
1072 break;
1073
1074 case T_SLVALUE:
1075 --w;
1076 break;
1077
1078 case T_ALVALUE:
1079 --w;
1080 case T_ARRAY:
1081 case T_MAPPING:
1082 arr_del(v->u.array);
1083 break;
1084
1085 case T_MLVALUE:
1086 i_del_value(--w);
1087 arr_del(v->u.array);
1088 break;
1089
1090 case T_SALVALUE:
1091 w -= 2;
1092 arr_del(v->u.array);
1093 break;
1094
1095 case T_SMLVALUE:
1096 w -= 2;
1097 i_del_value(w);
1098 arr_del(v->u.array);
1099 break;
1100 }
1101 v++;
1102 }
1103
1104 if (f->sos) {
1105 /* stack on stack */
1106 AFREE(f->stack);
1107 } else if (f->oindex != OBJ_NONE) {
1108 FREE(f->stack);
1109 }
1110 }
1111
1112 f->sp = v;
1113 f->lip = w;
1114 return f;
1115 }
1116
1117 /*
1118 * NAME: interpret->prev_object()
1119 * DESCRIPTION: return the nth previous object in the call_other chain
1120 */
1121 object *i_prev_object(f, n)
1122 register frame *f;
1123 register int n;
1124 {
1125 object *obj;
1126
1127 while (n >= 0) {
1128 /* back to last external call */
1129 while (!f->external) {
1130 f = f->prev;
1131 }
1132 f = f->prev;
1133 if (f->oindex == OBJ_NONE) {
1134 return (object *) NULL;
1135 }
1136 --n;
1137 }
1138 obj = OBJR(f->oindex);
1139 return (obj->count != 0) ? obj : (object *) NULL;
1140 }
1141
1142 /*
1143 * NAME: interpret->prev_program()
1144 * DESCRIPTION: return the nth previous program in the function call chain
1145 */
1146 char *i_prev_program(f, n)
1147 register frame *f;
1148 register int n;
1149 {
1150 while (n >= 0) {
1151 f = f->prev;
1152 if (f->oindex == OBJ_NONE) {
1153 return (char *) NULL;
1154 }
1155 --n;
1156 }
1157
1158 return OBJR(f->p_ctrl->oindex)->chain.name;
1159 }
1160
1161 /*
1162 * NAME: interpret->typecheck()
1163 * DESCRIPTION: check the argument types given to a function
1164 */
1165 void i_typecheck(f, name, ftype, proto, nargs, strict)
1166 register frame *f;
1167 char *name, *ftype;
1168 register char *proto;
1169 int nargs;
1170 int strict;
1171 {
1172 char tnbuf[8];
1173 register int i, n, atype, ptype;
1174 register char *args;
1175
1176 i = nargs;
1177 n = PROTO_NARGS(proto);
1178 args = PROTO_ARGS(proto);
1179 while (n > 0 && i > 0) {
1180 --i;
1181 ptype = UCHAR(*args);
1182 if (ptype & (T_VARARGS | T_ELLIPSIS)) {
1183 ptype &= ~(T_VARARGS | T_ELLIPSIS);
1184 if (n == 1) {
1185 if (ptype == T_MIXED || ptype == T_LVALUE) {
1186 return;
1187 }
1188 } else {
1189 args++;
1190 --n;
1191 }
1192 } else {
1193 args++;
1194 --n;
1195 }
1196
1197 if (ptype != T_MIXED) {
1198 atype = f->sp[i].type;
1199 if (ptype != atype && (atype != T_ARRAY || !(ptype & T_REF))) {
1200 if (!VAL_NIL(f->sp + i) || !T_POINTER(ptype)) {
1201 /* wrong type */
1202 error("Bad argument %d (%s) for %s %s", nargs - i,
1203 i_typename(tnbuf, atype), ftype, name);
1204 } else if (strict) {
1205 /* zero argument */
1206 error("Bad argument %d for %s %s", nargs - i, ftype, name);
1207 }
1208 }
1209 }
1210 }
1211 }
1212
1213 /*
1214 * NAME: interpret->switch_int()
1215 * DESCRIPTION: handle an int switch
1216 */
1217 static unsigned short i_switch_int(f, pc)
1218 register frame *f;
1219 register char *pc;
1220 {
1221 register unsigned short h, l, m, sz, dflt;
1222 register Int num;
1223 register char *p;
1224
1225 FETCH2U(pc, h);
1226 sz = FETCH1U(pc);
1227 FETCH2U(pc, dflt);
1228 if (f->sp->type != T_INT) {
1229 return dflt;
1230 }
1231
1232 l = 0;
1233 --h;
1234 switch (sz) {
1235 case 1:
1236 while (l < h) {
1237 m = (l + h) >> 1;
1238 p = pc + 3 * m;
1239 num = FETCH1S(p);
1240 if (f->sp->u.number == num) {
1241 return FETCH2U(p, l);
1242 } else if (f->sp->u.number < num) {
1243 h = m; /* search in lower half */
1244 } else {
1245 l = m + 1; /* search in upper half */
1246 }
1247 }
1248 break;
1249
1250 case 2:
1251 while (l < h) {
1252 m = (l + h) >> 1;
1253 p = pc + 4 * m;
1254 FETCH2S(p, num);
1255 if (f->sp->u.number == num) {
1256 return FETCH2U(p, l);
1257 } else if (f->sp->u.number < num) {
1258 h = m; /* search in lower half */
1259 } else {
1260 l = m + 1; /* search in upper half */
1261 }
1262 }
1263 break;
1264
1265 case 3:
1266 while (l < h) {
1267 m = (l + h) >> 1;
1268 p = pc + 5 * m;
1269 FETCH3S(p, num);
1270 if (f->sp->u.number == num) {
1271 return FETCH2U(p, l);
1272 } else if (f->sp->u.number < num) {
1273 h = m; /* search in lower half */
1274 } else {
1275 l = m + 1; /* search in upper half */
1276 }
1277 }
1278 break;
1279
1280 case 4:
1281 while (l < h) {
1282 m = (l + h) >> 1;
1283 p = pc + 6 * m;
1284 FETCH4S(p, num);
1285 if (f->sp->u.number == num) {
1286 return FETCH2U(p, l);
1287 } else if (f->sp->u.number < num) {
1288 h = m; /* search in lower half */
1289 } else {
1290 l = m + 1; /* search in upper half */
1291 }
1292 }
1293 break;
1294 }
1295
1296 return dflt;
1297 }
1298
1299 /*
1300 * NAME: interpret->switch_range()
1301 * DESCRIPTION: handle a range switch
1302 */
1303 static unsigned short i_switch_range(f, pc)
1304 register frame *f;
1305 register char *pc;
1306 {
1307 register unsigned short h, l, m, sz, dflt;
1308 register Int num;
1309 register char *p;
1310
1311 FETCH2U(pc, h);
1312 sz = FETCH1U(pc);
1313 FETCH2U(pc, dflt);
1314 if (f->sp->type != T_INT) {
1315 return dflt;
1316 }
1317
1318 l = 0;
1319 --h;
1320 switch (sz) {
1321 case 1:
1322 while (l < h) {
1323 m = (l + h) >> 1;
1324 p = pc + 4 * m;
1325 num = FETCH1S(p);
1326 if (f->sp->u.number < num) {
1327 h = m; /* search in lower half */
1328 } else {
1329 num = FETCH1S(p);
1330 if (f->sp->u.number <= num) {
1331 return FETCH2U(p, l);
1332 }
1333 l = m + 1; /* search in upper half */
1334 }
1335 }
1336 break;
1337
1338 case 2:
1339 while (l < h) {
1340 m = (l + h) >> 1;
1341 p = pc + 6 * m;
1342 FETCH2S(p, num);
1343 if (f->sp->u.number < num) {
1344 h = m; /* search in lower half */
1345 } else {
1346 FETCH2S(p, num);
1347 if (f->sp->u.number <= num) {
1348 return FETCH2U(p, l);
1349 }
1350 l = m + 1; /* search in upper half */
1351 }
1352 }
1353 break;
1354
1355 case 3:
1356 while (l < h) {
1357 m = (l + h) >> 1;
1358 p = pc + 8 * m;
1359 FETCH3S(p, num);
1360 if (f->sp->u.number < num) {
1361 h = m; /* search in lower half */
1362 } else {
1363 FETCH3S(p, num);
1364 if (f->sp->u.number <= num) {
1365 return FETCH2U(p, l);
1366 }
1367 l = m + 1; /* search in upper half */
1368 }
1369 }
1370 break;
1371
1372 case 4:
1373 while (l < h) {
1374 m = (l + h) >> 1;
1375 p = pc + 10 * m;
1376 FETCH4S(p, num);
1377 if (f->sp->u.number < num) {
1378 h = m; /* search in lower half */
1379 } else {
1380 FETCH4S(p, num);
1381 if (f->sp->u.number <= num) {
1382 return FETCH2U(p, l);
1383 }
1384 l = m + 1; /* search in upper half */
1385 }
1386 }
1387 break;
1388 }
1389 return dflt;
1390 }
1391
1392 /*
1393 * NAME: interpret->switch_str()
1394 * DESCRIPTION: handle a string switch
1395 */
1396 static unsigned short i_switch_str(f, pc)
1397 register frame *f;
1398 register char *pc;
1399 {
1400 register unsigned short h, l, m, u, u2, dflt;
1401 register int cmp;
1402 register char *p;
1403 register control *ctrl;
1404
1405 FETCH2U(pc, h);
1406 FETCH2U(pc, dflt);
1407 if (FETCH1U(pc) == 0) {
1408 FETCH2U(pc, l);
1409 if (VAL_NIL(f->sp)) {
1410 return l;
1411 }
1412 --h;
1413 }
1414 if (f->sp->type != T_STRING) {
1415 return dflt;
1416 }
1417
1418 ctrl = f->p_ctrl;
1419 l = 0;
1420 --h;
1421 while (l < h) {
1422 m = (l + h) >> 1;
1423 p = pc + 5 * m;
1424 u = FETCH1U(p);
1425 cmp = str_cmp(f->sp->u.string, d_get_strconst(ctrl, u, FETCH2U(p, u2)));
1426 if (cmp == 0) {
1427 return FETCH2U(p, l);
1428 } else if (cmp < 0) {
1429 h = m; /* search in lower half */
1430 } else {
1431 l = m + 1; /* search in upper half */
1432 }
1433 }
1434 return dflt;
1435 }
1436
1437 /*
1438 * NAME: interpret->catcherr()
1439 * DESCRIPTION: handle caught error
1440 */
1441 void i_catcherr(f, depth)
1442 frame *f;
1443 Int depth;
1444 {
1445 i_runtime_error(f, depth);
1446 }
1447
1448 /*
1449 * NAME: interpret->interpret()
1450 * DESCRIPTION: Main interpreter function. Interpret stack machine code.
1451 */
1452 static void i_interpret(f, pc)
1453 register frame *f;
1454 register char *pc;
1455 {
1456 register unsigned short instr, u, u2;
1457 register Uint l;
1458 register char *p;
1459 register kfunc *kf;
1460 int size;
1461 Int newdepth, newticks;
1462 bool atomic;
1463
1464 size = 0;
1465
1466 for (;;) {
1467 # ifdef DEBUG
1468 if (f->sp < f->lip + MIN_STACK) {
1469 fatal("out of value stack");
1470 }
1471 # endif
1472 if (--f->rlim->ticks <= 0) {
1473 if (f->rlim->noticks) {
1474 f->rlim->ticks = 0x7fffffff;
1475 } else {
1476 error("Out of ticks");
1477 }
1478 }
1479 instr = FETCH1U(pc);
1480 f->pc = pc;
1481
1482 switch (instr & I_INSTR_MASK) {
1483 case I_PUSH_ZERO:
1484 PUSH_INTVAL(f, 0);
1485 break;
1486
1487 case I_PUSH_ONE:
1488 PUSH_INTVAL(f, 1);
1489 break;
1490
1491 case I_PUSH_INT1:
1492 PUSH_INTVAL(f, FETCH1S(pc));
1493 break;
1494
1495 case I_PUSH_INT4:
1496 PUSH_INTVAL(f, FETCH4S(pc, l));
1497 break;
1498
1499 case I_PUSH_FLOAT:
1500 FETCH2U(pc, u);
1501 PUSH_FLTCONST(f, u, FETCH4U(pc, l));
1502 break;
1503
1504 case I_PUSH_STRING:
1505 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, f->p_ctrl->ninherits - 1,
1506 FETCH1U(pc)));
1507 break;
1508
1509 case I_PUSH_NEAR_STRING:
1510 u = FETCH1U(pc);
1511 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, u, FETCH1U(pc)));
1512 break;
1513
1514 case I_PUSH_FAR_STRING:
1515 u = FETCH1U(pc);
1516 PUSH_STRVAL(f, d_get_strconst(f->p_ctrl, u, FETCH2U(pc, u2)));
1517 break;
1518
1519 case I_PUSH_LOCAL:
1520 u = FETCH1S(pc);
1521 i_push_value(f, ((short) u < 0) ? f->fp + (short) u : f->argp + u);
1522 break;
1523
1524 case I_PUSH_GLOBAL:
1525 u = f->ctrl->inherits[f->p_index - 1].varoffset + FETCH1U(pc);
1526 i_push_value(f, d_get_variable(f->data, u));
1527 break;
1528
1529 case I_PUSH_FAR_GLOBAL:
1530 u = FETCH1U(pc);
1531 if (u != 0) {
1532 u = f->ctrl->inherits[f->p_index - u].varoffset;
1533 }
1534 i_push_value(f, d_get_variable(f->data, u + FETCH1U(pc)));
1535 break;
1536
1537 case I_PUSH_LOCAL_LVAL:
1538 u = FETCH1S(pc);
1539 (--f->sp)->type = T_LVALUE;
1540 f->sp->oindex = (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0;
1541 f->sp->u.lval = ((short) u < 0) ? f->fp + (short) u : f->argp + u;
1542 continue;
1543
1544 case I_PUSH_GLOBAL_LVAL:
1545 u = f->ctrl->inherits[f->p_index - 1].varoffset + FETCH1U(pc);
1546 (--f->sp)->type = T_LVALUE;
1547 f->sp->oindex = (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0;
1548 f->sp->u.lval = d_get_variable(f->data, u);
1549 continue;
1550
1551 case I_PUSH_FAR_GLOBAL_LVAL:
1552 u = FETCH1U(pc);
1553 if (u != 0) {
1554 u = f->ctrl->inherits[f->p_index - u].varoffset;
1555 }
1556 u += FETCH1U(pc);
1557 (--f->sp)->type = T_LVALUE;
1558 f->sp->oindex = (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0;
1559 f->sp->u.lval = d_get_variable(f->data, u);
1560 continue;
1561
1562 case I_INDEX:
1563 i_index(f);
1564 break;
1565
1566 case I_INDEX_LVAL:
1567 i_index_lvalue(f, (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0);
1568 continue;
1569
1570 case I_AGGREGATE:
1571 if (FETCH1U(pc) == 0) {
1572 i_aggregate(f, FETCH2U(pc, u));
1573 } else {
1574 i_map_aggregate(f, FETCH2U(pc, u));
1575 }
1576 break;
1577
1578 case I_SPREAD:
1579 u = FETCH1S(pc);
1580 size = i_spread(f, (short) u,
1581 (instr & I_TYPE_BIT) ? FETCH1U(pc) : 0);
1582 continue;
1583
1584 case I_CAST:
1585 i_cast(f->sp, FETCH1U(pc));
1586 break;
1587
1588 case I_FETCH:
1589 i_fetch(f);
1590 break;
1591
1592 case I_STORE:
1593 i_store(f);
1594 f->sp[1] = f->sp[0];
1595 f->sp++;
1596 break;
1597
1598 case I_JUMP:
1599 p = f->prog + FETCH2U(pc, u);
1600 pc = p;
1601 break;
1602
1603 case I_JUMP_ZERO:
1604 p = f->prog + FETCH2U(pc, u);
1605 if (!VAL_TRUE(f->sp)) {
1606 pc = p;
1607 }
1608 break;
1609
1610 case I_JUMP_NONZERO:
1611 p = f->prog + FETCH2U(pc, u);
1612 if (VAL_TRUE(f->sp)) {
1613 pc = p;
1614 }
1615 break;
1616
1617 case I_SWITCH:
1618 switch (FETCH1U(pc)) {
1619 case SWITCH_INT:
1620 pc = f->prog + i_switch_int(f, pc);
1621 break;
1622
1623 case SWITCH_RANGE:
1624 pc = f->prog + i_switch_range(f, pc);
1625 break;
1626
1627 case SWITCH_STRING:
1628 pc = f->prog + i_switch_str(f, pc);
1629 break;
1630 }
1631 break;
1632
1633 case I_CALL_KFUNC:
1634 kf = &KFUN(FETCH1U(pc));
1635 if (PROTO_CLASS(kf->proto) & C_KFUN_VARARGS) {
1636 /* variable # of arguments */
1637 u = FETCH1U(pc) + size;
1638 size = 0;
1639 } else {
1640 /* fixed # of arguments */
1641 u = PROTO_NARGS(kf->proto);
1642 }
1643 if (PROTO_CLASS(kf->proto) & C_TYPECHECKED) {
1644 i_typecheck(f, kf->name, "kfun", kf->proto, u, TRUE);
1645 }
1646 u = (*kf->func)(f, u, kf);
1647 if (u != 0) {
1648 if ((short) u < 0) {
1649 error("Too few arguments for kfun %s", kf->name);
1650 } else if (u <= PROTO_NARGS(kf->proto)) {
1651 error("Bad argument %d for kfun %s", u, kf->name);
1652 } else {
1653 error("Too many arguments for kfun %s", kf->name);
1654 }
1655 }
1656 break;
1657
1658 case I_CALL_AFUNC:
1659 u = FETCH1U(pc);
1660 i_funcall(f, (object *) NULL, 0, u, FETCH1U(pc) + size);
1661 size = 0;
1662 break;
1663
1664 case I_CALL_DFUNC:
1665 u = FETCH1U(pc);
1666 if (u != 0) {
1667 u = f->p_index - u;
1668 }
1669 u2 = FETCH1U(pc);
1670 i_funcall(f, (object *) NULL, u, u2, FETCH1U(pc) + size);
1671 size = 0;
1672 break;
1673
1674 case I_CALL_FUNC:
1675 p = &f->ctrl->funcalls[2L * (f->foffset + FETCH2U(pc, u))];
1676 i_funcall(f, (object *) NULL, UCHAR(p[0]), UCHAR(p[1]),
1677 FETCH1U(pc) + size);
1678 size = 0;
1679 break;
1680
1681 case I_CATCH:
1682 p = f->prog + FETCH2U(pc, u);
1683 atomic = f->atomic;
1684 f->atomic = FALSE;
1685 if (!ec_push((ec_ftn) i_catcherr)) {
1686 i_interpret(f, pc);
1687 ec_pop();
1688 pc = f->pc;
1689 *--f->sp = nil_value;
1690 } else {
1691 /* error */
1692 f->pc = pc = p;
1693 PUSH_STRVAL(f, errorstr());
1694 }
1695 f->atomic = atomic;
1696 break;
1697
1698 case I_RLIMITS:
1699 if (f->sp[1].type != T_INT) {
1700 error("Bad rlimits depth type");
1701 }
1702 if (f->sp->type != T_INT) {
1703 error("Bad rlimits ticks type");
1704 }
1705 newdepth = f->sp[1].u.number;
1706 newticks = f->sp->u.number;
1707 if (!FETCH1U(pc)) {
1708 /* runtime check */
1709 i_check_rlimits(f);
1710 } else {
1711 /* pop limits */
1712 f->sp += 2;
1713 }
1714
1715 i_new_rlimits(f, newdepth, newticks);
1716 i_interpret(f, pc);
1717 pc = f->pc;
1718 i_set_rlimits(f, f->rlim->next);
1719 break;
1720
1721 case I_RETURN:
1722 return;
1723 }
1724
1725 if (instr & I_POP_BIT) {
1726 /* pop the result of the last operation (never an lvalue) */
1727 i_del_value(f->sp++);
1728 }
1729 }
1730 }
1731
1732 /*
1733 * NAME: interpret->funcall()
1734 * DESCRIPTION: Call a function in an object. The arguments must be on the
1735 * stack already.
1736 */
1737 void i_funcall(prev_f, obj, p_ctrli, funci, nargs)
1738 register frame *prev_f;
1739 register object *obj;
1740 register int p_ctrli, nargs;
1741 int funci;
1742 {
1743 register char *pc;
1744 register unsigned short n;
1745 frame f;
1746 value val;
1747
1748 f.prev = prev_f;
1749 if (prev_f->oindex == OBJ_NONE) {
1750 /*
1751 * top level call
1752 */
1753 f.oindex = obj->index;
1754 f.ctrl = obj->ctrl;
1755 f.data = o_dataspace(obj);
1756 f.external = TRUE;
1757 } else if (obj != (object *) NULL) {
1758 /*
1759 * call_other
1760 */
1761 f.oindex = obj->index;
1762 f.ctrl = obj->ctrl;
1763 f.data = o_dataspace(obj);
1764 f.external = TRUE;
1765 } else {
1766 /*
1767 * local function call
1768 */
1769 f.oindex = prev_f->oindex;
1770 f.ctrl = prev_f->ctrl;
1771 f.data = prev_f->data;
1772 f.external = FALSE;
1773 }
1774 f.depth = prev_f->depth + 1;
1775 f.rlim = prev_f->rlim;
1776 if (f.depth >= f.rlim->maxdepth && !f.rlim->nodepth) {
1777 error("Stack overflow");
1778 }
1779 if (f.rlim->ticks < 100) {
1780 if (f.rlim->noticks) {
1781 f.rlim->ticks = 0x7fffffff;
1782 } else {
1783 error("Out of ticks");
1784 }
1785 }
1786
1787 /* set the program control block */
1788 obj = OBJR(f.ctrl->inherits[p_ctrli].oindex);
1789 f.foffset = f.ctrl->inherits[p_ctrli].funcoffset;
1790 f.p_ctrl = o_control(obj);
1791 f.p_index = p_ctrli + 1;
1792
1793 /* get the function */
1794 f.func = &d_get_funcdefs(f.p_ctrl)[funci];
1795 if (f.func->class & C_UNDEFINED) {
1796 error("Undefined function %s",
1797 d_get_strconst(f.p_ctrl, f.func->inherit, f.func->index)->text);
1798 }
1799
1800 pc = d_get_prog(f.p_ctrl) + f.func->offset;
1801 if (f.func->class & C_TYPECHECKED) {
1802 /* typecheck arguments */
1803 i_typecheck(prev_f, d_get_strconst(f.p_ctrl, f.func->inherit,
1804 f.func->index)->text,
1805 "function", pc, nargs, FALSE);
1806 }
1807
1808 /* handle arguments */
1809 n = PROTO_NARGS(pc);
1810 pc = PROTO_ARGS(pc);
1811 if (n > 0 && (UCHAR(pc[n - 1]) & T_ELLIPSIS)) {
1812 register value *v;
1813 array *a;
1814
1815 if (nargs >= n) {
1816 /* put additional arguments in array */
1817 nargs -= n - 1;
1818 a = arr_new(f.data, (long) nargs);
1819 v = a->elts + nargs;
1820 do {
1821 *--v = *prev_f->sp++;
1822 } while (--nargs > 0);
1823 d_ref_imports(a);
1824 nargs = n;
1825 pc += nargs;
1826 } else {
1827 /* if fewer actual than formal parameters, check for varargs */
1828 if (nargs + 1 != n && stricttc && !(f.func->class & C_VARARGS)) {
1829 register unsigned short i;
1830
1831 i = nargs;
1832 do {
1833 if (i == 0) {
1834 error("Insufficient arguments for function %s",
1835 d_get_strconst(f.p_ctrl, f.func->inherit,
1836 f.func->index)->text);
1837 }
1838 --i;
1839 } while (!(FETCH1U(pc) & T_VARARGS));
1840 pc += i;
1841 } else {
1842 pc += nargs;
1843 }
1844
1845 /* make empty arguments array, and optionally push zeros */
1846 i_grow_stack(prev_f, n - nargs);
1847 while (++nargs < n) {
1848 switch (FETCH1U(pc)) {
1849 case T_INT:
1850 *--prev_f->sp = zero_int;
1851 break;
1852
1853 case T_FLOAT:
1854 *--prev_f->sp = zero_float;
1855 break;
1856
1857 default:
1858 *--prev_f->sp = nil_value;
1859 break;
1860 }
1861 }
1862 pc++;
1863 a = arr_new(f.data, 0L);
1864 }
1865 PUSH_ARRVAL(prev_f, a);
1866 } else if (nargs > n) {
1867 if (stricttc) {
1868 error("Too many arguments for function %s",
1869 d_get_strconst(f.p_ctrl, f.func->inherit,
1870 f.func->index)->text);
1871 }
1872
1873 /* pop superfluous arguments */
1874 i_pop(prev_f, nargs - n);
1875 nargs = n;
1876 pc += nargs;
1877 } else if (nargs < n) {
1878 /* if fewer actual than formal parameters, check for varargs */
1879 if (stricttc && !(f.func->class & C_VARARGS)) {
1880 register unsigned short i;
1881
1882 i = nargs;
1883 do {
1884 if (i == 0) {
1885 error("Insufficient arguments for function %s",
1886 d_get_strconst(f.p_ctrl, f.func->inherit,
1887 f.func->index)->text);
1888 }
1889 --i;
1890 } while (!(FETCH1U(pc) & T_VARARGS));
1891 pc += i;
1892 } else {
1893 pc += nargs;
1894 }
1895
1896 /* add missing arguments */
1897 i_grow_stack(prev_f, n - nargs);
1898 do {
1899 switch (FETCH1U(pc)) {
1900 case T_INT:
1901 *--prev_f->sp = zero_int;
1902 break;
1903
1904 case T_FLOAT:
1905 *--prev_f->sp = zero_float;
1906 break;
1907
1908 default:
1909 *--prev_f->sp = nil_value;
1910 break;
1911 }
1912 } while (++nargs < n);
1913 } else {
1914 pc += nargs;
1915 }
1916 f.sp = prev_f->sp;
1917 f.nargs = nargs;
1918 cframe = &f;
1919
1920 /* deal with atomic functions */
1921 f.level = prev_f->level;
1922 if ((f.func->class & C_ATOMIC) && !prev_f->atomic) {
1923 o_new_plane();
1924 d_new_plane(f.data, ++f.level);
1925 f.atomic = TRUE;
1926 if (!f.rlim->noticks) {
1927 f.rlim->ticks >>= 1;
1928 }
1929 } else {
1930 if (f.level != f.data->plane->level) {
1931 d_new_plane(f.data, f.level);
1932 }
1933 f.atomic = prev_f->atomic;
1934 }
1935
1936 i_add_ticks(&f, 10);
1937
1938 if ((obj->flags & O_SPECIAL) != O_SPECIAL ||
1939 ext_funcall == (bool (*) P((frame*, int, value*, char*))) NULL ||
1940 !(*ext_funcall)(&f, nargs, &val,
1941 d_get_strconst(f.p_ctrl, f.func->inherit,
1942 f.func->index)->text)) {
1943 /*
1944 * ordinary function call
1945 */
1946
1947 /* create new local stack */
1948 f.argp = f.sp;
1949 FETCH2U(pc, n);
1950 f.stack = f.lip = ALLOCA(value, n + MIN_STACK + EXTRA_STACK);
1951 f.fp = f.sp = f.stack + n + MIN_STACK + EXTRA_STACK;
1952 f.sos = TRUE;
1953
1954 /* initialize local variables */
1955 n = FETCH1U(pc);
1956 # ifdef DEBUG
1957 nargs = n;
1958 # endif
1959 if (n > 0) {
1960 do {
1961 *--f.sp = nil_value;
1962 } while (--n > 0);
1963 }
1964
1965 /* execute code */
1966 d_get_funcalls(f.ctrl); /* make sure they are available */
1967 if (f.func->class & C_COMPILED) {
1968 Uint l;
1969
1970 /* compiled function */
1971 (*pcfunctions[FETCH3U(pc, l)])(&f);
1972 } else {
1973 /* interpreted function */
1974 f.prog = pc += 2;
1975 i_interpret(&f, pc);
1976 }
1977
1978 /* clean up stack, move return value to outer stackframe */
1979 val = *f.sp++;
1980 # ifdef DEBUG
1981 if (f.sp != f.fp - nargs || f.lip != f.stack) {
1982 fatal("bad stack pointer after function call");
1983 }
1984 # endif
1985 i_pop(&f, f.fp - f.sp);
1986 if (f.sos) {
1987 /* still alloca'd */
1988 AFREE(f.stack);
1989 } else {
1990 /* extended and malloced */
1991 FREE(f.stack);
1992 }
1993 }
1994
1995 cframe = prev_f;
1996 i_pop(prev_f, f.nargs);
1997 *--prev_f->sp = val;
1998
1999 if ((f.func->class & C_ATOMIC) && !prev_f->atomic) {
2000 d_commit_plane(f.level, &val);
2001 o_commit_plane();
2002 if (!f.rlim->noticks) {
2003 f.rlim->ticks *= 2;
2004 }
2005 }
2006 }
2007
2008 /*
2009 * NAME: interpret->call()
2010 * DESCRIPTION: Attempt to call a function in an object. Return TRUE if
2011 * the call succeeded.
2012 */
2013 bool i_call(f, obj, func, len, call_static, nargs)
2014 frame *f;
2015 object *obj;
2016 char *func;
2017 unsigned int len;
2018 int call_static;
2019 int nargs;
2020 {
2021 register dsymbol *symb;
2022 register dfuncdef *fdef;
2023 register control *ctrl;
2024
2025 ctrl = o_control(obj);
2026 if (!(obj->flags & O_CREATED)) {
2027 /*
2028 * initialize the object
2029 */
2030 obj = OBJW(obj->index);
2031 obj->flags |= O_CREATED;
2032 if (i_call(f, obj, creator, clen, TRUE, 0)) {
2033 i_del_value(f->sp++);
2034 }
2035 }
2036
2037 /* find the function in the symbol table */
2038 symb = ctrl_symb(ctrl, func, len);
2039 if (symb == (dsymbol *) NULL) {
2040 /* function doesn't exist in symbol table */
2041 i_pop(f, nargs);
2042 return FALSE;
2043 }
2044
2045 ctrl = OBJR(ctrl->inherits[UCHAR(symb->inherit)].oindex)->ctrl;
2046 fdef = &d_get_funcdefs(ctrl)[UCHAR(symb->index)];
2047
2048 /* check if the function can be called */
2049 if (!call_static && (fdef->class & C_STATIC) && f->oindex != obj->index) {
2050 i_pop(f, nargs);
2051 return FALSE;
2052 }
2053
2054 /* call the function */
2055 i_funcall(f, obj, UCHAR(symb->inherit), UCHAR(symb->index), nargs);
2056
2057 return TRUE;
2058 }
2059
2060 /*
2061 * NAME: interpret->line()
2062 * DESCRIPTION: return the line number the program counter of the specified
2063 * frame is at
2064 */
2065 static unsigned short i_line(f)
2066 register frame *f;
2067 {
2068 register char *pc, *numbers;
2069 register int instr;
2070 register short offset;
2071 register unsigned short line, u, sz;
2072
2073 line = 0;
2074 pc = f->p_ctrl->prog + f->func->offset;
2075 pc += PROTO_SIZE(pc) + 3;
2076 FETCH2U(pc, u);
2077 numbers = pc + u;
2078
2079 while (pc < f->pc) {
2080 instr = FETCH1U(pc);
2081
2082 offset = instr >> I_LINE_SHIFT;
2083 if (offset <= 2) {
2084 /* simple offset */
2085 line += offset;
2086 } else {
2087 offset = FETCH1U(numbers);
2088 if (offset >= 128) {
2089 /* one byte offset */
2090 line += offset - 128 - 64;
2091 } else {
2092 /* two byte offset */
2093 line += ((offset << 8) | FETCH1U(numbers)) - 16384;
2094 }
2095 }
2096
2097 switch (instr & I_INSTR_MASK) {
2098 case I_INDEX_LVAL:
2099 if (instr & I_TYPE_BIT) {
2100 pc++;
2101 }
2102 /* fall through */
2103 case I_PUSH_ZERO:
2104 case I_PUSH_ONE:
2105 case I_INDEX:
2106 case I_FETCH:
2107 case I_STORE:
2108 case I_RETURN:
2109 break;
2110
2111 case I_PUSH_LOCAL_LVAL:
2112 case I_PUSH_GLOBAL_LVAL:
2113 case I_SPREAD:
2114 if (instr & I_TYPE_BIT) {
2115 pc++;
2116 }
2117 /* fall through */
2118 case I_PUSH_INT1:
2119 case I_PUSH_STRING:
2120 case I_PUSH_LOCAL:
2121 case I_PUSH_GLOBAL:
2122 case I_CAST:
2123 case I_RLIMITS:
2124 pc++;
2125 break;
2126
2127 case I_PUSH_FAR_GLOBAL_LVAL:
2128 if (instr & I_TYPE_BIT) {
2129 pc++;
2130 }
2131 /* fall through */
2132 case I_PUSH_NEAR_STRING:
2133 case I_PUSH_FAR_GLOBAL:
2134 case I_JUMP:
2135 case I_JUMP_ZERO:
2136 case I_JUMP_NONZERO:
2137 case I_CALL_AFUNC:
2138 case I_CATCH:
2139 pc += 2;
2140 break;
2141
2142 case I_PUSH_FAR_STRING:
2143 case I_AGGREGATE:
2144 case I_CALL_DFUNC:
2145 case I_CALL_FUNC:
2146 pc += 3;
2147 break;
2148
2149 case I_PUSH_INT4:
2150 pc += 4;
2151 break;
2152
2153 case I_PUSH_FLOAT:
2154 pc += 6;
2155 break;
2156
2157 case I_SWITCH:
2158 switch (FETCH1U(pc)) {
2159 case 0:
2160 FETCH2U(pc, u);
2161 sz = FETCH1U(pc);
2162 pc += 2 + (u - 1) * (sz + 2);
2163 break;
2164
2165 case 1:
2166 FETCH2U(pc, u);
2167 sz = FETCH1U(pc);
2168 pc += 2 + (u - 1) * (2 * sz + 2);
2169 break;
2170
2171 case 2:
2172 FETCH2U(pc, u);
2173 pc += 2;
2174 if (FETCH1U(pc) == 0) {
2175 pc += 2;
2176 --u;
2177 }
2178 pc += (u - 1) * 5;
2179 break;
2180 }
2181 break;
2182
2183 case I_CALL_KFUNC:
2184 if (PROTO_CLASS(KFUN(FETCH1U(pc)).proto) & C_KFUN_VARARGS) {
2185 pc++;
2186 }
2187 break;
2188 }
2189 }
2190
2191 return line;
2192 }
2193
2194 /*
2195 * NAME: interpret->func_trace()
2196 * DESCRIPTION: return the trace of a single function
2197 */
2198 static array *i_func_trace(f, data)
2199 register frame *f;
2200 dataspace *data;
2201 {
2202 char buffer[STRINGSZ + 12];
2203 register value *v;
2204 register string *str;
2205 register char *name;
2206 register unsigned short n;
2207 register value *args;
2208 array *a;
2209 unsigned short max_args;
2210
2211 max_args = conf_array_size() - 5;
2212
2213 n = f->nargs;
2214 args = f->argp + n;
2215 if (n > max_args) {
2216 /* unlikely, but possible */
2217 n = max_args;
2218 }
2219 a = arr_new(data, n + 5L);
2220 v = a->elts;
2221
2222 /* object name */
2223 name = o_name(buffer, OBJR(f->oindex));
2224 PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 1L));
2225 v++;
2226 str->text[0] = '/';
2227 strcpy(str->text + 1, name);
2228
2229 /* program name */
2230 name = OBJR(f->p_ctrl->oindex)->chain.name;
2231 PUT_STRVAL(v, str = str_new((char *) NULL, strlen(name) + 1L));
2232 v++;
2233 str->text[0] = '/';
2234 strcpy(str->text + 1, name);
2235
2236 /* function name */
2237 PUT_STRVAL(v, d_get_strconst(f->p_ctrl, f->func->inherit, f->func->index));
2238 v++;
2239
2240 /* line number */
2241 PUT_INTVAL(v, (f->func->class & C_COMPILED) ? 0 : i_line(f));
2242 v++;
2243
2244 /* external flag */
2245 PUT_INTVAL(v, f->external);
2246 v++;
2247
2248 /* arguments */
2249 while (n > 0) {
2250 *v++ = *--args;
2251 i_ref_value(args);
2252 --n;
2253 }
2254 d_ref_imports(a);
2255
2256 return a;
2257 }
2258
2259 /*
2260 * NAME: interpret->call_tracei()
2261 * DESCRIPTION: get the trace of a single function
2262 */
2263 bool i_call_tracei(ftop, idx, v)
2264 frame *ftop;
2265 Int idx;
2266 value *v;
2267 {
2268 register frame *f;
2269 register unsigned short n;
2270
2271 for (f = ftop, n = 0; f->oindex != OBJ_NONE; f = f->prev, n++) ;
2272 if (idx < 0 || idx >= n) {
2273 return FALSE;
2274 }
2275
2276 for (f = ftop, n -= idx + 1; n != 0; f = f->prev, --n) ;
2277 PUT_ARRVAL(v, i_func_trace(f, ftop->data));
2278 return TRUE;
2279 }
2280
2281 /*
2282 * NAME: interpret->call_trace()
2283 * DESCRIPTION: return the function call trace
2284 */
2285 array *i_call_trace(ftop)
2286 register frame *ftop;
2287 {
2288 register frame *f;
2289 register value *v;
2290 register unsigned short n;
2291 array *a;
2292
2293 for (f = ftop, n = 0; f->oindex != OBJ_NONE; f = f->prev, n++) ;
2294 a = arr_new(ftop->data, (long) n);
2295 i_add_ticks(ftop, 10 * n);
2296 for (f = ftop, v = a->elts + n; f->oindex != OBJ_NONE; f = f->prev) {
2297 --v;
2298 PUT_ARRVAL(v, i_func_trace(f, ftop->data));
2299 }
2300
2301 return a;
2302 }
2303
2304 /*
2305 * NAME: emptyhandler()
2306 * DESCRIPTION: fake error handler
2307 */
2308 static void emptyhandler(f, depth)
2309 frame *f;
2310 Int depth;
2311 {
2312 }
2313
2314 /*
2315 * NAME: interpret->call_critical()
2316 * DESCRIPTION: Call a function in the driver object at a critical moment.
2317 * The function is called with rlimits (-1; -1) and errors
2318 * caught.
2319 */
2320 bool i_call_critical(f, func, narg, flag)
2321 register frame *f;
2322 char *func;
2323 int narg, flag;
2324 {
2325 bool ok;
2326
2327 i_new_rlimits(f, -1, -1);
2328 f->sp += narg; /* so the error context knows what to pop */
2329 if (ec_push((flag) ? (ec_ftn) i_catcherr : (ec_ftn) emptyhandler)) {
2330 ok = FALSE;
2331 } else {
2332 f->sp -= narg; /* recover arguments */
2333 call_driver_object(f, func, narg);
2334 ec_pop();
2335 ok = TRUE;
2336 }
2337 i_set_rlimits(f, f->rlim->next);
2338
2339 return ok;
2340 }
2341
2342 /*
2343 * NAME: interpret->runtime_error()
2344 * DESCRIPTION: handle a runtime error
2345 */
2346 void i_runtime_error(f, depth)
2347 register frame *f;
2348 Int depth;
2349 {
2350 PUSH_STRVAL(f, errorstr());
2351 PUSH_INTVAL(f, depth);
2352 PUSH_INTVAL(f, i_get_ticks(f));
2353 if (!i_call_critical(f, "runtime_error", 3, FALSE)) {
2354 message("Error within runtime_error:\012"); /* LF */
2355 message((char *) NULL);
2356 } else {
2357 i_del_value(f->sp++);
2358 }
2359 }
2360
2361 /*
2362 * NAME: interpret->atomic_error()
2363 * DESCRIPTION: handle error in atomic code
2364 */
2365 void i_atomic_error(ftop, level)
2366 register frame *ftop;
2367 Int level;
2368 {
2369 register frame *f;
2370
2371 for (f = ftop; f->level != level; f = f->prev) ;
2372
2373 PUSH_STRVAL(ftop, errorstr());
2374 PUSH_INTVAL(ftop, f->depth);
2375 PUSH_INTVAL(ftop, i_get_ticks(ftop));
2376 if (!i_call_critical(ftop, "atomic_error", 3, FALSE)) {
2377 message("Error within atomic_error:\012"); /* LF */
2378 message((char *) NULL);
2379 } else {
2380 i_del_value(ftop->sp++);
2381 }
2382 }
2383
2384 /*
2385 * NAME: interpret->restore()
2386 * DESCRIPTION: restore state to given level
2387 */
2388 frame *i_restore(ftop, level)
2389 register frame *ftop;
2390 Int level;
2391 {
2392 register frame *f;
2393
2394 for (f = ftop; f->level != level; f = f->prev) ;
2395
2396 if (f->rlim != ftop->rlim) {
2397 i_set_rlimits(ftop, f->rlim);
2398 }
2399 if (!f->rlim->noticks) {
2400 f->rlim->ticks *= 2;
2401 }
2402 i_set_sp(ftop, f->sp);
2403 d_discard_plane(ftop->level);
2404 o_discard_plane();
2405
2406 return f;
2407 }
2408
2409 /*
2410 * NAME: interpret->clear()
2411 * DESCRIPTION: clean up the interpreter state
2412 */
2413 void i_clear()
2414 {
2415 register frame *f;
2416
2417 f = cframe;
2418 if (f->stack != stack) {
2419 FREE(f->stack);
2420 f->fp = f->sp = stack + MIN_STACK;
2421 f->stack = f->lip = stack;
2422 }
2423
2424 f->rlim = &rlim;
2425 }
2426
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.