ArchWizard

DGD/

source navigation ]
diff markup ]
identifier search ]
file search ]
Version: [ 1.0.a0 ] [ 1.1 ] [ 1.2 ] [ 1.2p1 ] [ 1.2p2 ] [ 1.2p3 ] [ 1.2p4 ] [ 1.2.151 ]

  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 

~ [ source navigation ] ~ [ diff markup ] ~ [ identifier search ] ~ [ file search ] ~

This page was automatically generated by the LXR engine.
Visit the LXR main site for more information.