![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to interp.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx|
Return to interp.c CVS log | Up to [Research Unix] / researchv10dc / cmd / icon / src / iconx |
1.1 root 1: /*
2: * The intepreter proper.
3: */
4:
5: /*
6: * Instrumentation selection is based on Instr_level, which is given
7: * as a product of prime numbers.
8: */
9: #ifndef Instr
10: #define Instr 997
11: #endif Instr
12: #ifndef Instr_level
13: #define Instr_level 2
14: #endif Instr_level
15:
16: #include "../h/rt.h"
17: #include "gc.h"
18: #include "../h/opdef.h"
19:
20: /*
21: * Istate variables.
22: */
23: struct pf_marker *pfp; /* Procedure frame pointer */
24: struct ef_marker *efp; /* Expression frame pointer */
25: struct gf_marker *gfp; /* Generator frame pointer */
26: word *ipc; /* Interpreter program counter */
27: struct descrip *argp; /* Pointer to argument zero */
28: word *sp; /* Stack pointer */
29: extern int mstksize; /* Size of main stack */
30: int ilevel; /* Depth of recursion in interp() */
31:
32: #if (Instr % Instr_level) == 0
33: int maxilevel; /* Maximum ilevel */
34: word *maxsp; /* Maximum interpreter sp */
35: #endif Instr
36:
37: extern word *stack; /* Interpreter stack */
38: word *stackend; /* End of main interpreter stack */
39:
40: #ifdef MSDOS
41: #ifdef LPTR
42: static union {
43: char *stkadr;
44: word stkint;
45: } stkword;
46: #define PushAVal(v) {sp++; \
47: stkword.stkadr = (char *)(v); \
48: *sp = stkword.stkint;}
49: #else LPTR
50: #define PushAVal PushVal
51: #endif LPTR
52: #else MSDOS
53: #define PushAVal PushVal
54: #endif MSDOS
55:
56: /*
57: * Initial icode sequence. This is used to invoke the main procedure with one
58: * operand. If main returns, the Op_Quit is executed.
59: */
60: word istart[3] = {Op_Invoke, 1, Op_Quit};
61: word mterm = Op_Quit;
62:
63: /*
64: * The tended descriptors.
65: */
66: struct descrip tended[6];
67:
68: /*
69: * Descriptor to hold result for eret across potential interp unwinding.
70: */
71: struct descrip eret_tmp;
72: /*
73: * Last co-expression action.
74: */
75: int coexp_act;
76: struct descrip *xargp;
77:
78: main(argc, argv)
79: int argc; char **argv;
80: {
81: int i;
82: extern int tallyopt;
83:
84: #if (Instr % Instr_level) == 0
85: maxilevel = 0;
86: maxsp = 0;
87: #endif Instr
88:
89: #ifdef VMS
90: redirect(&argc, argv, 0);
91: #endif VMS
92:
93: /*
94: * Set tallying flag if -T option given
95: */
96: if (!strcmp(argv[1],"-T")) {
97: tallyopt = 1;
98: argc--;
99: argv++;
100: }
101:
102:
103: /*
104: * Call init with the name of the file to interpret.
105: */
106: init(argv[1]);
107:
108: /*
109: * Point sp at word after b_coexpr block for &main, point ipc at initial
110: * icode segment, and clear the gfp.
111: */
112: stackend = stack + mstksize/WordSize;
113: sp = stack + Wsizeof(struct b_coexpr);
114: ipc = istart;
115: gfp = 0;
116:
117: /*
118: * Set up expression frame marker to contain execution of the
119: * main procedure. If failure occurs in this context, control
120: * is transferred to mterm, the address of an Op_Quit.
121: */
122: efp = (struct ef_marker *)(sp);
123: efp->ef_failure = &mterm;
124: efp->ef_gfp = 0;
125: efp->ef_efp = 0;
126: efp->ef_ilevel = 1;
127: sp += Wsizeof(*efp) - 1;
128:
129: /*
130: * The first global variable holds the value of "main". If it
131: * is not of type procedure, this is noted as run-time error 117.
132: * Otherwise, this value is pushed on the stack.
133: */
134: if (globals[0].dword != D_Proc)
135: runerr(117, NULL);
136: PushDesc(globals[0]);
137:
138: /*
139: * Main is to be invoked with one argument, a list of the command
140: * line arguments. The command line arguments are pushed on the
141: * stack as a series of descriptors and llist is called to create
142: * the list. The null descriptor first pushed serves as Arg0 for
143: * llist and receives the result of the computation.
144: */
145: PushNull;
146: argp = (struct descrip *)(sp - 1);
147: for (i = 2; i < argc; i++) {
148: PushVal(strlen(argv[i]));
149: PushAVal(argv[i]);
150: }
151: llist(argc - 2, argp);
152: sp = (word *)argp + 1;
153: argp = 0;
154:
155: /*
156: * Start things rolling by calling interp. This call to interp
157: * returns only if an Op_Quit is executed. If this happens,
158: * c_exit() is called to wrap things up.
159: */
160: interp(0,NULL);
161: c_exit(NormalExit);
162: }
163:
164: /*
165: * Macros for use inside the main loop of the interpreter.
166: */
167:
168: /*
169: * Setup_Op sets things up for a call to the C function for an operator.
170: */
171: #define Setup_Op(nargs) \
172: rargp = (struct descrip *) (rsp - 1) - nargs; \
173: ExInterp;
174:
175: /*
176: * Call_Op(n) calls an unconditional operator. The C routine associated
177: * with the current opcode is called. After the routine performs the operation
178: * and returns, the stack pointer is reset to point to the result.
179: */
180: #define Call_Op(n) (*(optab[op]))(rargp); \
181: rsp = (word *) rargp + 1;
182:
183: /*
184: * Call_Cond(n) calls a conditional operator. The C routine associated
185: * with the current opcode is called. The routine returns a signal of
186: * success or failure. If the operation succeeds, the stack
187: * pointer is reset to point to the result. If the routine fails, control
188: * transfers to efail.
189: */
190: #define Call_Cond(n) if ((*(optab[op]))(rargp) == A_Failure) \
191: goto efail; \
192: else \
193: rsp = (word *) rargp + 1;
194:
195: /*
196: * Call_Gen(n) - Call a generator. A C routine associated with the
197: * current opcode is called. When it when it terminates, control is
198: * passed to C_rtn_term to deal with the termination condition appropriately.
199: */
200: #define Call_Gen(n) signal = (*(optab[op]))(rargp); \
201: goto C_rtn_term;
202:
203: /*
204: * GetWord fetches the next icode word. PutWord(x) stores x at the current
205: * icode word.
206: */
207: #define GetWord (*ipc++)
208: #define PutWord(x) ipc[-1] = (x)
209: /*
210: * DerefArg(n) dereferences the n'th argument.
211: */
212: #define DerefArg(n) DeRef(rargp[n])
213:
214: /*
215: * For the sake of efficiency, the stack pointer is kept in a register
216: * variable, rsp, in the interpreter loop. Since this variable is
217: * only accessible inside the loop, and the global variable sp is used
218: * for the stack pointer elsewhere, rsp must be stored into sp when
219: * the context of the loop is left and conversely, rsp must be loaded
220: * from sp when the loop is reentered. The macros ExInterp and EntInterp,
221: * respectively, handle these operations. Currently, this register/global
222: * scheme is only used for the stack pointer, but it can be easily extended
223: * to other variables.
224: */
225:
226: #define ExInterp sp = rsp;
227: #define EntInterp rsp = sp;
228:
229: /*
230: * Inside the interpreter loop, PushDesc, PushNull, and
231: * PushVal use rsp instead of sp for efficiency.
232: */
233:
234: #undef PushDesc
235: #undef PushNull
236: #undef PushVal
237: #undef PushAVal
238: #define PushDesc(d) {rsp++;*rsp=((d).dword);rsp++;*rsp=((d).vword.integr);}
239: #define PushNull {rsp++; *rsp = D_Null; rsp++; *rsp = 0;}
240: #define PushVal(v) {rsp++; *rsp = (word)(v);}
241: #ifdef MSDOS
242: #ifdef LPTR
243: #define PushAVal(v) {rsp++; \
244: stkword.stkadr = (char *)(v); \
245: *rsp = stkword.stkint; \
246: }
247: #else LPTR
248: #define PushAVal PushVal
249: #endif LPTR
250: #else MSDOS
251: #define PushAVal PushVal
252: #endif MSDOS
253:
254: /*
255: * The main loop of the interpreter.
256: */
257:
258: interp(fsig,cargp)
259: int fsig;
260: struct descrip *cargp;
261: {
262: register word opnd, op;
263: register word *rsp;
264: register struct descrip *rargp;
265: register struct ef_marker *newefp;
266: register struct gf_marker *newgfp;
267: register word *wd;
268: register word *firstwd, *lastwd;
269: word *oldsp;
270: int type, signal;
271: extern int (*optab[])();
272: extern char *ident;
273: extern word tallybin[];
274:
275: ilevel++;
276: #if (Instr % Instr_level) == 0
277: if (ilevel > maxilevel)
278: maxilevel = ilevel;
279: #endif Instr
280: EntInterp;
281: if (fsig == G_Csusp) {
282: oldsp = rsp;
283:
284: /*
285: * Create the generator frame.
286: */
287: newgfp = (struct gf_marker *)(rsp + 1);
288: newgfp->gf_gentype = G_Csusp;
289: newgfp->gf_gfp = gfp;
290: newgfp->gf_efp = efp;
291: newgfp->gf_ipc = ipc;
292: newgfp->gf_line = line;
293: rsp += Wsizeof(struct gf_smallmarker);
294:
295: /*
296: * Region extends from first word after the marker for the generator
297: * or expression frame enclosing the call to the now-suspending
298: * routine to the first argument of the routine.
299: */
300: if (gfp != 0) {
301: if (gfp->gf_gentype == G_Psusp)
302: firstwd = (word *)gfp + Wsizeof(*gfp);
303: else
304: firstwd = (word *)gfp + Wsizeof(struct gf_smallmarker);
305: }
306: else
307: firstwd = (word *)efp + Wsizeof(*efp);
308: lastwd = (word *)cargp + 1;
309:
310: /*
311: * Copy the portion of the stack with endpoints firstwd and lastwd
312: * (inclusive) to the top of the stack.
313: */
314: for (wd = firstwd; wd <= lastwd; wd++)
315: *++rsp = *wd;
316: gfp = newgfp;
317: }
318: for (;;) { /* Top of the interpreter loop */
319: #if (Instr % Instr_level) == 0
320: if (sp > maxsp)
321: maxsp = sp;
322: #endif Instr
323: op = GetWord; /* Instruction fetch */
324:
325: switch (op) { /*
326: * Switch on opcode. The cases are
327: * organized roughly by functionality
328: * to make it easier to find things.
329: * For some C compilers, there may be
330: * an advantage to arranging them by
331: * likelihood of selection.
332: */
333:
334: /* ---Constant construction--- */
335:
336: case Op_Cset: /* cset */
337: PutWord(Op_Acset);
338: PushVal(D_Cset);
339: opnd = GetWord;
340: opnd += (word)ipc;
341: PutWord(opnd);
342: PushAVal(opnd);
343: break;
344:
345: case Op_Acset: /* cset, absolute address */
346: PushVal(D_Cset);
347: PushAVal(GetWord);
348: break;
349:
350:
351: /* >int */
352: case Op_Int: /* integer */
353: PushVal(D_Integer);
354: PushVal(GetWord);
355: break;
356: /* <int */
357:
358: #if IntSize == 16
359: case Op_Long: /* long integer */
360: PutWord(Op_Along);
361: PushVal(D_Longint);
362: opnd = GetWord;
363: opnd += (word)(ipc);
364: PutWord(opnd);
365: PushAVal(opnd);
366: break;
367:
368: case Op_Along: /* long integer, absolute address */
369: PushVal(D_Longint);
370: PushAVal(GetWord);
371: break;
372: #endif IntSize == 16
373:
374: case Op_Real: /* real */
375: PutWord(Op_Areal);
376: PushVal(D_Real);
377: opnd = GetWord;
378: opnd += (word)ipc;
379: PushAVal(opnd);
380: PutWord(opnd);
381: break;
382:
383: case Op_Areal: /* real, absolute address */
384: PushVal(D_Real);
385: PushAVal(GetWord);
386: break;
387:
388: case Op_Str: /* string */
389: PutWord(Op_Astr);
390: PushVal(GetWord)
391: opnd = (word)ident + GetWord;
392: PutWord(opnd);
393: PushAVal(opnd);
394: break;
395:
396: case Op_Astr: /* string, absolute address */
397: PushVal(GetWord);
398: PushAVal(GetWord);
399: break;
400:
401: /* ---Variable construction--- */
402:
403: case Op_Arg: /* argument */
404: PushVal(D_Var);
405: PushAVal(&argp[GetWord + 1]);
406: break;
407:
408: case Op_Global: /* global */
409: PutWord(Op_Aglobal);
410: PushVal(D_Var);
411: opnd = GetWord;
412: PushAVal(&globals[opnd]);
413: PutWord((word)&globals[opnd]);
414: break;
415:
416: case Op_Aglobal: /* global, absolute address */
417: PushVal(D_Var);
418: PushAVal(GetWord);
419: break;
420:
421: case Op_Local: /* local */
422: PushVal(D_Var);
423: PushAVal(&pfp->pf_locals[GetWord]);
424: break;
425:
426: case Op_Static: /* static */
427: PutWord(Op_Astatic);
428: PushVal(D_Var);
429: opnd = GetWord;
430: PushAVal(&statics[opnd]);
431: PutWord((word)&statics[opnd]);
432: break;
433:
434: case Op_Astatic: /* static, absolute address */
435: PushVal(D_Var);
436: PushAVal(GetWord);
437: break;
438:
439: /* ---Operators--- */
440:
441: /* Unconditional unary operators */
442:
443: case Op_Compl: /* ~e */
444: case Op_Neg: /* -e */
445: case Op_Number: /* +e */
446: case Op_Refresh: /* ^e */
447: case Op_Size: /* *e */
448: case Op_Value: /* .e */
449: Setup_Op(1);
450: DerefArg(1);
451: Call_Op(1);
452: break;
453: /* Conditional unary operators */
454:
455: case Op_Nonnull: /* \e */
456: case Op_Null: /* /e */
457: Setup_Op(1);
458: Call_Cond(1);
459: break;
460:
461: case Op_Random: /* ?e */
462: PushNull;
463: Setup_Op(2)
464: Call_Cond(2)
465: break;
466:
467: /* Generative unary operators */
468:
469: case Op_Tabmat: /* =e */
470: Setup_Op(1);
471: DerefArg(1);
472: Call_Gen(1);
473: break;
474:
475: case Op_Bang: /* !e */
476: PushNull;
477: Setup_Op(2);
478: Call_Gen(2);
479: break;
480:
481: /* Unconditional binary operators */
482:
483: case Op_Cat: /* e1 || e2 */
484: case Op_Diff: /* e1 -- e2 */
485: case Op_Div: /* e1 / e2 */
486: case Op_Inter: /* e1 ** e2 */
487: case Op_Lconcat: /* e1 ||| e2 */
488: case Op_Minus: /* e1 - e2 */
489: case Op_Mod: /* e1 % e2 */
490: case Op_Mult: /* e1 * e2 */
491: case Op_Power: /* e1 ^ e2 */
492: case Op_Unions: /* e1 ++ e2 */
493: /* >plus */
494: case Op_Plus: /* e1 + e2 */
495: Setup_Op(2);
496: DerefArg(1);
497: DerefArg(2);
498: Call_Op(2);
499: break;
500: /* <plus */
501: /* Conditional binary operators */
502:
503: case Op_Eqv: /* e1 === e2 */
504: case Op_Lexeq: /* e1 == e2 */
505: case Op_Lexge: /* e1 >>= e2 */
506: case Op_Lexgt: /* e1 >> e2 */
507: case Op_Lexle: /* e1 <<= e2 */
508: case Op_Lexlt: /* e1 << e2 */
509: case Op_Lexne: /* e1 ~== e2 */
510: case Op_Neqv: /* e1 ~=== e2 */
511: case Op_Numeq: /* e1 = e2 */
512: case Op_Numge: /* e1 >= e2 */
513: case Op_Numgt: /* e1 > e2 */
514: case Op_Numle: /* e1 <= e2 */
515: case Op_Numne: /* e1 ~= e2 */
516: /* >numlt */
517: case Op_Numlt: /* e1 < e2 */
518: Setup_Op(2);
519: DerefArg(1);
520: DerefArg(2);
521: Call_Cond(2);
522: break;
523: /* <numlt */
524:
525: case Op_Asgn: /* e1 := e2 */
526: Setup_Op(2);
527: DerefArg(2);
528: Call_Cond(2);
529: break;
530:
531: case Op_Swap: /* e1 :=: e2 */
532: PushNull;
533: Setup_Op(3);
534: Call_Cond(3);
535: break;
536:
537: case Op_Subsc: /* e1[e2] */
538: PushNull;
539: Setup_Op(3);
540: DerefArg(2);
541: Call_Cond(3);
542: break;
543: /* Generative binary operators */
544:
545: case Op_Rasgn: /* e1 <- e2 */
546: Setup_Op(2);
547: DerefArg(2);
548: Call_Gen(2);
549: break;
550:
551: case Op_Rswap: /* e1 <-> e2 */
552: PushNull;
553: Setup_Op(3);
554: Call_Gen(3);
555: break;
556:
557: /* Conditional ternary operators */
558:
559: case Op_Sect: /* e1[e2:e3] */
560: PushNull;
561: Setup_Op(4);
562: DerefArg(2);
563: DerefArg(3);
564: Call_Cond(4);
565: break;
566: /* Generative ternary operators */
567:
568: case Op_Toby: /* e1 to e2 by e3 */
569: Setup_Op(3);
570: DerefArg(1);
571: DerefArg(2);
572: DerefArg(3);
573: Call_Gen(3);
574: break;
575:
576: /* ---String Scanning--- */
577:
578: case Op_Bscan: /* prepare for scanning */
579: PushDesc(k_subject);
580: PushVal(D_Integer);
581: PushVal(k_pos);
582: Setup_Op(0);
583: signal = bscan(0,rargp);
584: goto C_rtn_term;
585:
586: case Op_Escan: /* exit from scanning */
587: Setup_Op(3);
588: signal = escan(3,rargp);
589: goto C_rtn_term;
590:
591: /* ---Other Language Operations--- */
592:
593: case Op_Invoke: { /* invoke */
594: ExInterp;
595: { int nargs;
596: struct descrip *carg;
597:
598: type = invoke((int)GetWord, &carg, &nargs);
599: rargp = carg;
600: EntInterp;
601: if (type == I_Goal_Fail)
602: goto efail;
603: if (type == I_Continue)
604: break;
605: else {
606: int (*bfunc)();
607: struct b_proc *bproc;
608:
609: bproc = (struct b_proc *)BlkLoc(*rargp);
610: bfunc = bproc->entryp.ccode;
611:
612: /* ExInterp -- not needed since no change
613: since last EntInterp */
614: if (type == I_Vararg)
615: signal = (*bfunc)(nargs,rargp);
616: else
617: signal = (*bfunc)(rargp);
618: goto C_rtn_term;
619: }
620: }
621: break;
622: }
623:
624: case Op_Keywd: /* keyword */
625: PushVal(D_Integer);
626: PushVal(GetWord);
627: Setup_Op(0);
628: signal = keywd(0,rargp);
629: break;
630:
631: case Op_Llist: /* construct list */
632: opnd = GetWord;
633: Setup_Op(opnd);
634: llist((int)opnd,rargp);
635: rsp = (word *) rargp + 1;
636: break;
637:
638: /* ---Marking and Unmarking--- */
639:
640: case Op_Mark: /* create expression frame marker */
641: PutWord(Op_Amark);
642: opnd = GetWord;
643: opnd += (word)ipc;
644: PutWord(opnd);
645: newefp = (struct ef_marker *)(rsp + 1);
646: newefp->ef_failure = (word *)opnd;
647: goto mark;
648:
649: case Op_Amark: /* mark with absolute fipc */
650: newefp = (struct ef_marker *)(rsp + 1);
651: newefp->ef_failure = (word *)GetWord;
652: mark:
653: newefp->ef_gfp = gfp;
654: newefp->ef_efp = efp;
655: newefp->ef_ilevel = ilevel;
656: rsp += Wsizeof(*efp);
657: efp = newefp;
658: gfp = 0;
659: break;
660:
661: case Op_Mark0: /* create expression frame with 0 ipl */
662: mark0:
663: newefp = (struct ef_marker *)(rsp + 1);
664: newefp->ef_failure = 0;
665: newefp->ef_gfp = gfp;
666: newefp->ef_efp = efp;
667: newefp->ef_ilevel = ilevel;
668: rsp += Wsizeof(*efp);
669: efp = newefp;
670: gfp = 0;
671: break;
672:
673: /* >unmark */
674: case Op_Unmark: /* remove expression frame */
675: gfp = efp->ef_gfp;
676: rsp = (word *)efp - 1;
677:
678: /*
679: * Remove any suspended C generators.
680: */
681: Unmark_uw:
682: if (efp->ef_ilevel != ilevel) {
683: --ilevel;
684: ExInterp;
685: return A_Unmark_uw;
686: }
687: efp = efp->ef_efp;
688: break;
689: /* <unmark */
690:
691: /* ---Suspensions--- */
692:
693: case Op_Esusp: { /* suspend from expression */
694:
695: /*
696: * Create the generator frame.
697: */
698: oldsp = rsp;
699: newgfp = (struct gf_marker *)(rsp + 1);
700: newgfp->gf_gentype = G_Esusp;
701: newgfp->gf_gfp = gfp;
702: newgfp->gf_efp = efp;
703: newgfp->gf_ipc = ipc;
704: newgfp->gf_line = line;
705: gfp = newgfp;
706: rsp += Wsizeof(struct gf_smallmarker);
707:
708: /*
709: * Region extends from first word after enclosing generator or
710: * expression frame marker to marker for current expression frame.
711: */
712: if (efp->ef_gfp != 0) {
713: newgfp = (struct gf_marker *)(efp->ef_gfp);
714: if (newgfp->gf_gentype == G_Psusp)
715: firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
716: else
717: firstwd = (word *)efp->ef_gfp + Wsizeof(struct gf_smallmarker);
718: }
719: else
720: firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
721: lastwd = (word *)efp - 1;
722: efp = efp->ef_efp;
723:
724: /*
725: * Copy the portion of the stack with endpoints firstwd and lastwd
726: * (inclusive) to the top of the stack.
727: */
728: for (wd = firstwd; wd <= lastwd; wd++)
729: *++rsp = *wd;
730: PushVal(oldsp[-1]);
731: PushVal(oldsp[0]);
732: break;
733: }
734:
735: case Op_Lsusp: { /* suspend from limitation */
736: struct descrip sval;
737:
738: /*
739: * The limit counter is contained in the descriptor immediately
740: * prior to the current expression frame. lval is established
741: * as a pointer to this descriptor.
742: */
743: struct descrip *lval = (struct descrip *)((word *)efp - 2);
744:
745: /*
746: * Decrement the limit counter and check it.
747: */
748: if (--IntVal(*lval) != 0) {
749: /*
750: * The limit has not been reached, set up stack.
751: */
752:
753: sval = *(struct descrip *)(rsp - 1); /* save result */
754:
755: /*
756: * Region extends from first word after enclosing generator or
757: * expression frame marker to the limit counter just prior to
758: * to the current expression frame marker.
759: */
760: if (efp->ef_gfp != 0) {
761: newgfp = (struct gf_marker *)(efp->ef_gfp);
762: if (newgfp->gf_gentype == G_Psusp)
763: firstwd = (word *)efp->ef_gfp + Wsizeof(*gfp);
764: else
765: firstwd = (word *)efp->ef_gfp + Wsizeof(struct gf_smallmarker);
766: }
767: else
768: firstwd = (word *)efp->ef_efp + Wsizeof(*efp);
769: lastwd = (word *)efp - 3;
770: efp = efp->ef_efp;
771:
772: /*
773: * Copy the portion of the stack with endpoints firstwd and lastwd
774: * (inclusive) to the top of the stack.
775: */
776: rsp -= 2; /* overwrite result */
777: for (wd = firstwd; wd <= lastwd; wd++)
778: *++rsp = *wd;
779: PushDesc(sval); /* push saved result */
780: }
781: else {
782: /*
783: * Otherwise, the limit has been reached. Instead of
784: * suspending, remove the current expression frame and
785: * replace the limit counter with the value on top of
786: * the stack (which would have been suspended had the
787: * limit not been reached).
788: */
789: *lval = *(struct descrip *)(rsp - 1);
790: gfp = efp->ef_gfp;
791:
792: /*
793: * Since an expression frame is being removed, inactive
794: * C generators contained therein are deactivated.
795: */
796: Lsusp_uw:
797: if (efp->ef_ilevel != ilevel) {
798: --ilevel;
799: ExInterp;
800: return A_Lsusp_uw;
801: }
802: rsp = (word *)efp - 1;
803: efp = efp->ef_efp;
804: }
805: break;
806: }
807:
808: case Op_Psusp: { /* suspend from procedure */
809: /*
810: * An Icon procedure is suspending a value. Determine if the
811: * value being suspended should be dereferenced and if so,
812: * dereference it. If tracing is on, strace is called
813: * to generate a message. Appropriate values are
814: * restored from the procedure frame of the suspending procedure.
815: */
816:
817: struct descrip sval, *svalp;
818: struct b_proc *sproc;
819:
820: svalp = (struct descrip *)(rsp - 1);
821: sval = *svalp;
822: if (Var(sval)) {
823: word *loc;
824:
825: if (Tvar(sval)) {
826: if (sval.dword == D_Tvsubs) {
827: struct b_tvsubs *tvb;
828:
829: tvb = (struct b_tvsubs *)BlkLoc(sval);
830: loc = (word *)BlkLoc(tvb->ssvar);
831: }
832: else
833: goto ps_noderef;
834: }
835: else
836: loc = (word *)BlkLoc(sval);
837: if (loc >= (word *)BlkLoc(current) && loc <= rsp)
838: deref(svalp);
839: }
840: ps_noderef:
841:
842: /*
843: * Create the generator frame.
844: */
845: oldsp = rsp;
846: newgfp = (struct gf_marker *)(rsp + 1);
847: newgfp->gf_gentype = G_Psusp;
848: newgfp->gf_gfp = gfp;
849: newgfp->gf_efp = efp;
850: newgfp->gf_ipc = ipc;
851: newgfp->gf_line = line;
852: newgfp->gf_argp = argp;
853: newgfp->gf_pfp = pfp;
854: gfp = newgfp;
855: rsp += Wsizeof(*gfp);
856:
857: /*
858: * Region extends from first word after the marker for the generator
859: * or expression frame enclosing the call to the now-suspending
860: * procedure to Arg0 of the procedure.
861: */
862: if (pfp->pf_gfp != 0) {
863: newgfp = (struct gf_marker *)(pfp->pf_gfp);
864: if (newgfp->gf_gentype == G_Psusp)
865: firstwd = (word *)pfp->pf_gfp + Wsizeof(*gfp);
866: else
867: firstwd = (word *)pfp->pf_gfp + Wsizeof(struct gf_smallmarker);
868: }
869: else
870: firstwd = (word *)pfp->pf_efp + Wsizeof(*efp);
871: lastwd = (word *)argp - 1;
872: efp = efp->ef_efp;
873:
874: /*
875: * Copy the portion of the stack with endpoints firstwd and lastwd
876: * (inclusive) to the top of the stack.
877: */
878: for (wd = firstwd; wd <= lastwd; wd++)
879: *++rsp = *wd;
880: PushVal(oldsp[-1]);
881: PushVal(oldsp[0]);
882: --k_level;
883: if (k_trace) {
884: sproc = (struct b_proc *)BlkLoc(*argp);
885: strace(sproc, svalp);
886: }
887: line = pfp->pf_line;
888: efp = pfp->pf_efp;
889: ipc = pfp->pf_ipc;
890: argp = pfp->pf_argp;
891: pfp = pfp->pf_pfp;
892: break;
893: }
894:
895: /* ---Returns--- */
896:
897: case Op_Eret: { /* return from expression */
898: /*
899: * Op_Eret removes the current expression frame, leaving the
900: * original top of stack value on top.
901: */
902: /*
903: * Save current top of stack value in global temporary (no
904: * danger of reentry).
905: */
906: eret_tmp = *(struct descrip *)&rsp[-1];
907: gfp = efp->ef_gfp;
908: Eret_uw:
909: /*
910: * Since an expression frame is being removed, inactive
911: * C generators contained therein are deactivated.
912: */
913: if (efp->ef_ilevel != ilevel) {
914: --ilevel;
915: ExInterp;
916: return A_Eret_uw;
917: }
918: rsp = (word *)efp - 1;
919: efp = efp->ef_efp;
920: PushDesc(eret_tmp);
921: break;
922: }
923:
924: case Op_Pret: { /* return from procedure */
925: /*
926: * An Icon procedure is returning a value. Determine if the
927: * value being returned should be dereferenced and if so,
928: * dereference it. If tracing is on, rtrace is called to
929: * generate a message. Inactive generators created after
930: * the activation of the procedure are deactivated. Appropriate
931: * values are restored from the procedure frame.
932: */
933: struct descrip rval;
934: struct b_proc *rproc = (struct b_proc *)BlkLoc(*argp);
935:
936: *argp = *(struct descrip *)(rsp - 1);
937: rval = *argp;
938: if (Var(rval)) {
939: word *loc;
940:
941: if (Tvar(rval)) {
942: if (rval.dword == D_Tvsubs) {
943: struct b_tvsubs *tvb;
944:
945: tvb = (struct b_tvsubs *)BlkLoc(rval);
946: loc = (word *)BlkLoc(tvb->ssvar);
947: }
948: else
949: goto pr_noderef;
950: }
951: else
952: loc = (word *)BlkLoc(rval);
953: if (loc >= (word *)BlkLoc(current) && loc <= rsp)
954: deref(argp);
955: }
956:
957: pr_noderef:
958: --k_level;
959: if (k_trace)
960: rtrace(rproc, argp);
961: Pret_uw:
962: if (pfp->pf_ilevel != ilevel) {
963: --ilevel;
964: ExInterp;
965: return A_Pret_uw;
966: }
967: rsp = (word *)argp + 1;
968: line = pfp->pf_line;
969: efp = pfp->pf_efp;
970: gfp = pfp->pf_gfp;
971: ipc = pfp->pf_ipc;
972: argp = pfp->pf_argp;
973: pfp = pfp->pf_pfp;
974: break;
975: }
976:
977: /* ---Failures--- */
978:
979: /* >efail1 */
980: case Op_Efail:
981: efail:
982: /*
983: * Failure has occurred in the current expression frame.
984: */
985: if (gfp == 0) {
986: /*
987: * There are no inactive generators to resume. Remove
988: * the current expression frame, restoring values.
989: *
990: * If the failure address is 0, propagate failure to the
991: * enclosing frame by branching back to efail.
992: */
993: ipc = efp->ef_failure;
994: gfp = efp->ef_gfp;
995: rsp = (word *)efp - 1;
996: efp = efp->ef_efp;
997: if (ipc == 0)
998: goto efail;
999: break;
1000: }
1001:
1002: else {
1003: /*
1004: * There is a generator that can be resumed. Make
1005: * the stack adjustments and then switch on the
1006: * type of the generator frame marker.
1007: */
1008: register struct gf_marker *resgfp = gfp;
1009:
1010: type = resgfp->gf_gentype;
1011: /* <efail1 */
1012: if (type == G_Psusp) {
1013: argp = resgfp->gf_argp;
1014: if (k_trace) { /* procedure tracing */
1015: ExInterp;
1016: atrace(BlkLoc(*argp));
1017: EntInterp;
1018: }
1019: }
1020: /* >efail2 */
1021: ipc = resgfp->gf_ipc;
1022: efp = resgfp->gf_efp;
1023: line = resgfp->gf_line;
1024: gfp = resgfp->gf_gfp;
1025: rsp = (word *)resgfp - 1;
1026: /* <efail2 */
1027: if (type == G_Psusp) {
1028: pfp = resgfp->gf_pfp;
1029: ++k_level; /* adjust procedure level */
1030: }
1031:
1032: /* >efail3 */
1033: switch (type) {
1034:
1035: case G_Csusp: {
1036: --ilevel;
1037: ExInterp;
1038: return A_Resumption;
1039: break;
1040: }
1041:
1042: case G_Esusp:
1043: goto efail;
1044:
1045: case G_Psusp:
1046: break;
1047: }
1048:
1049: break;
1050: }
1051: /* <efail3 */
1052:
1053: case Op_Pfail: /* fail from procedure */
1054: /*
1055: * An Icon procedure is failing. Generate tracing message if
1056: * tracing is on. Deactivate inactive C generators created
1057: * after activation of the procedure. Appropriate values
1058: * are restored from the procedure frame.
1059: */
1060: --k_level;
1061: if (k_trace)
1062: ftrace(BlkLoc(*argp));
1063: Pfail_uw:
1064: if (pfp->pf_ilevel != ilevel) {
1065: --ilevel;
1066: ExInterp;
1067: return A_Pfail_uw;
1068: }
1069: line = pfp->pf_line;
1070: efp = pfp->pf_efp;
1071: gfp = pfp->pf_gfp;
1072: ipc = pfp->pf_ipc;
1073: argp = pfp->pf_argp;
1074: pfp = pfp->pf_pfp;
1075: goto efail;
1076:
1077: /* ---Odds and Ends--- */
1078:
1079: case Op_Ccase: /* case clause */
1080: PushNull;
1081: PushVal(((word *)efp)[-2]);
1082: PushVal(((word *)efp)[-1]);
1083: break;
1084:
1085: case Op_Chfail: /* change failure ipc */
1086: opnd = GetWord;
1087: opnd += (word)ipc;
1088: efp->ef_failure = (word *)opnd;
1089: break;
1090:
1091: case Op_Dup: /* duplicate descriptor */
1092: PushNull;
1093: rsp[1] = rsp[-3];
1094: rsp[2] = rsp[-2];
1095: rsp += 2;
1096: break;
1097:
1098: case Op_Field: /* e1.e2 */
1099: PushVal(D_Integer);
1100: PushVal(GetWord);
1101: Setup_Op(2);
1102: signal = field(2,rargp);
1103: goto C_rtn_term;
1104:
1105: case Op_Goto: /* goto */
1106: PutWord(Op_Agoto);
1107: opnd = GetWord;
1108: opnd += (word)ipc;
1109: PutWord(opnd);
1110: ipc = (word *)opnd;
1111: break;
1112:
1113: case Op_Agoto: /* goto absolute address */
1114: opnd = GetWord;
1115: ipc = (word *)opnd;
1116: break;
1117:
1118: case Op_Init: /* initial */
1119: *--ipc = Op_Goto;
1120: opnd = sizeof(*ipc) + sizeof(*rsp);
1121: opnd += (word)ipc;
1122: ipc = (word *)opnd;
1123: break;
1124:
1125: case Op_Limit: /* limit */
1126: Setup_Op(0);
1127: if (limit(0,rargp) == A_Failure)
1128: goto efail;
1129: else
1130: rsp = (word *) rargp + 1;
1131: goto mark0;
1132:
1133: case Op_Line: /* line */
1134: line = GetWord;
1135: break;
1136:
1137: case Op_Tally: /* tally */
1138: tallybin[GetWord]++;
1139: break;
1140:
1141: case Op_Pnull: /* push null descriptor */
1142: PushNull;
1143: break;
1144:
1145: case Op_Pop: /* pop descriptor */
1146: rsp -= 2;
1147: break;
1148:
1149: case Op_Push1: /* push integer 1 */
1150: PushVal(D_Integer);
1151: PushVal(1);
1152: break;
1153:
1154: case Op_Pushn1: /* push integer -1 */
1155: PushVal(D_Integer);
1156: PushVal(-1);
1157: break;
1158:
1159: case Op_Sdup: /* duplicate descriptor */
1160: rsp += 2;
1161: rsp[-1] = rsp[-3];
1162: rsp[0] = rsp[-2];
1163: break;
1164:
1165: /* ---Co-expressions--- */
1166:
1167: case Op_Create: /* create */
1168: PushNull;
1169: Setup_Op(0);
1170: opnd = GetWord;
1171: opnd += (word)ipc;
1172: signal = create((word *)opnd, rargp);
1173: goto C_rtn_term;
1174:
1175:
1176: case Op_Coact: { /* @e */
1177: register struct b_coexpr *ccp, *ncp;
1178: struct descrip *dp, *tvalp;
1179: word first;
1180:
1181: ExInterp;
1182: dp = (struct descrip *)(sp - 1);
1183: DeRef(*dp);
1184: if (dp->dword != D_Coexpr)
1185: runerr(118, dp);
1186: ccp = (struct b_coexpr *)BlkLoc(current);
1187: ncp = (struct b_coexpr *)BlkLoc(*dp);
1188: if (ncp->tvalloc != NULL) /* Cannot activate co-expression */
1189: runerr(214, NULL); /* that is already active */
1190: /*
1191: * Save Istate of current co-expression.
1192: */
1193: ccp->es_pfp = pfp;
1194: ccp->es_argp = argp;
1195: ccp->es_efp = efp;
1196: ccp->es_gfp = gfp;
1197: ccp->es_ipc = ipc;
1198: ccp->es_sp = sp;
1199: ccp->es_ilevel = ilevel;
1200: ccp->es_line = line;
1201: ccp->tvalloc = (struct descrip *)(sp - 3);
1202: /*
1203: * Establish Istate for new co-expression.
1204: */
1205: pfp = ncp->es_pfp;
1206: argp = ncp->es_argp;
1207: efp = ncp->es_efp;
1208: gfp = ncp->es_gfp;
1209: ipc = ncp->es_ipc;
1210: sp = ncp->es_sp;
1211: ilevel = ncp->es_ilevel;
1212: line = ncp->es_line;
1213:
1214: if (tvalp = ncp->tvalloc) {
1215: ncp->tvalloc = NULL;
1216: *tvalp = *(struct descrip *)(&ccp->es_sp[-3]);
1217: if (Var(*tvalp)) {
1218: word *loc;
1219:
1220: if (Tvar(*tvalp)) {
1221: if (tvalp->dword == D_Tvsubs) {
1222: struct b_tvsubs *tvb;
1223:
1224: tvb = (struct b_tvsubs *)BlkLoc(*tvalp);
1225: loc = (word *)BlkLoc(tvb->ssvar);
1226: }
1227: else
1228: goto ca_noderef;
1229: }
1230: else
1231: loc = (word *)BlkLoc(*tvalp);
1232: if (loc >= (word *)ccp && loc <= ccp->es_sp)
1233: deref(tvalp);
1234: }
1235: }
1236: ca_noderef:
1237: /*
1238: * Set activator in new co-expression.
1239: */
1240: if (ncp->activator.dword == D_Null)
1241: first = 0;
1242: else
1243: first = 1;
1244: ncp->activator.dword = D_Coexpr;
1245: BlkLoc(ncp->activator) = (union block *)ccp;
1246: BlkLoc(current) = (union block *)ncp;
1247: coexp_act = A_Coact;
1248: coswitch(ccp->cstate,ncp->cstate,first);
1249: EntInterp;
1250: if (coexp_act == A_Cofail)
1251: goto efail;
1252: else
1253: rsp -= 2;
1254: break;
1255: }
1256:
1257: case Op_Coret: { /* return from co-expression */
1258: register struct b_coexpr *ccp, *ncp;
1259: struct descrip *rvalp;
1260:
1261: ExInterp;
1262: ccp = (struct b_coexpr *)BlkLoc(current);
1263: ccp->size++;
1264: ncp = (struct b_coexpr *)BlkLoc(ccp->activator);
1265: ncp->tvalloc = NULL;
1266: rvalp = (struct descrip *)(&ncp->es_sp[-3]);
1267: *rvalp = *(struct descrip *)&sp[-1];
1268: if (Var(*rvalp)) {
1269: word *loc;
1270:
1271: if (Tvar(*rvalp)) {
1272: if (rvalp->dword == D_Tvsubs) {
1273: struct b_tvsubs *tvb;
1274:
1275: tvb = (struct b_tvsubs *)BlkLoc(*rvalp);
1276: loc = (word *)BlkLoc(tvb->ssvar);
1277: }
1278: else
1279: goto cr_noderef;
1280: }
1281: else
1282: loc = (word *)BlkLoc(*rvalp);
1283: if (loc >= (word *)ccp && loc <= sp)
1284: deref(rvalp);
1285: }
1286: cr_noderef:
1287: /*
1288: * Save Istate of current co-expression.
1289: */
1290: ccp->es_pfp = pfp;
1291: ccp->es_argp = argp;
1292: ccp->es_efp = efp;
1293: ccp->es_gfp = gfp;
1294: ccp->es_ipc = ipc;
1295: ccp->es_sp = sp;
1296: ccp->es_ilevel = ilevel;
1297: ccp->es_line = line;
1298: /*
1299: * Establish Istate for new co-expression.
1300: */
1301: pfp = ncp->es_pfp;
1302: argp = ncp->es_argp;
1303: efp = ncp->es_efp;
1304: gfp = ncp->es_gfp;
1305: ipc = ncp->es_ipc;
1306: sp = ncp->es_sp;
1307: ilevel = ncp->es_ilevel;
1308: line = ncp->es_line;
1309: BlkLoc(current) = (union block *)ncp;
1310: coexp_act = A_Coret;
1311: coswitch(ccp->cstate, ncp->cstate,(word)1);
1312: break;
1313: }
1314:
1315: case Op_Cofail: { /* fail from co-expression */
1316: register struct b_coexpr *ccp, *ncp;
1317:
1318: ExInterp;
1319: ccp = (struct b_coexpr *)BlkLoc(current);
1320: ncp = (struct b_coexpr *)BlkLoc(ccp->activator);
1321: ncp->tvalloc = NULL;
1322: /*
1323: * Save Istate of current co-expression.
1324: */
1325: ccp->es_pfp = pfp;
1326: ccp->es_argp = argp;
1327: ccp->es_efp = efp;
1328: ccp->es_gfp = gfp;
1329: ccp->es_ipc = ipc;
1330: ccp->es_sp = sp;
1331: ccp->es_ilevel = ilevel;
1332: ccp->es_line = line;
1333: /*
1334: * Establish Istate for new co-expression.
1335: */
1336: pfp = ncp->es_pfp;
1337: argp = ncp->es_argp;
1338: efp = ncp->es_efp;
1339: gfp = ncp->es_gfp;
1340: ipc = ncp->es_ipc;
1341: sp = ncp->es_sp;
1342: ilevel = ncp->es_ilevel;
1343: line = ncp->es_line;
1344: BlkLoc(current) = (union block *)ncp;
1345: coexp_act = A_Cofail;
1346: coswitch(ccp->cstate, ncp->cstate,(word)1);
1347: break;
1348: }
1349:
1350: case Op_Quit: /* quit */
1351: goto interp_quit;
1352:
1353: default: {
1354: char buf[50];
1355:
1356: sprintf(buf, "unimplemented opcode: %ld\n",(long)op);
1357: syserr(buf);
1358: }
1359: }
1360: continue;
1361:
1362: /* >crtn */
1363: C_rtn_term:
1364: EntInterp;
1365: switch (signal) {
1366:
1367: case A_Failure:
1368: goto efail;
1369:
1370: case A_Unmark_uw: /* unwind for unmark */
1371: goto Unmark_uw;
1372:
1373: case A_Lsusp_uw: /* unwind for lsusp */
1374: goto Lsusp_uw;
1375:
1376: case A_Eret_uw: /* unwind for eret */
1377: goto Eret_uw;
1378:
1379: case A_Pret_uw: /* unwind for pret */
1380: goto Pret_uw;
1381:
1382: case A_Pfail_uw: /* unwind for pfail */
1383: goto Pfail_uw;
1384: }
1385:
1386: rsp = (word *) rargp + 1; /* set rsp to result */
1387: continue;
1388: }
1389: /* <crtn */
1390:
1391: interp_quit:
1392: --ilevel;
1393: #if (Instr % Instr_level) == 0
1394: fprintf(stderr,"maximum ilevel = %d\n",maxilevel);
1395: fprintf(stderr,"maximum sp = %d\n",(long)maxsp - (long)stack);
1396: fflush(stderr);
1397: #endif Instr
1398: if (ilevel != 0)
1399: syserr("Interpreter termination with inactive generators!");
1400: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.