1 #ifdef RCSID
2 static char RCSid[] =
3 "$Header: d:/cvsroot/tads/TADS2/RUN.C,v 1.2 1999/05/17 02:52:13 MJRoberts Exp $";
4 #endif
5
6 /*
7 * Copyright (c) 1991, 2002 Michael J. Roberts. All Rights Reserved.
8 *
9 * Please see the accompanying license file, LICENSE.TXT, for information
10 * on using and copying this software.
11 */
12 /*
13 Name
14 run.c - code execution
15 Function
16 Executes p-code
17 Notes
18 Due to the highly mobile memory architecture of this version of TADS,
19 objects and data within objects can move at certain junctures. At
20 these times, pointers to object data become invalid, and it's necessary
21 to re-establish those pointers. Two functions are provided to facilitate
22 this. runcpsav() is called prior to an operation that may move object
23 data; it returns the offset within the object and property of the
24 code being executed, and unlocks the object. runcprst() is called
25 after such an operation; it relocks the object, and returns a pointer
26 to the property data. Note that the special property number zero is
27 used for functions; this indicates that no prpdef structuring is done
28 on the object, but that its actual data start at offset 0.
29 Modified
30 04/11/99 CNebel - Fix warnings.
31 10/20/91 MJRoberts - creation
32 */
33
34 #include <stdlib.h>
35 #include <string.h>
36
37 #include "os.h"
38 #include "run.h"
39 #include "dbg.h"
40 #include "lst.h"
41 #include "obj.h"
42 #include "voc.h"
43 #include "sup.h"
44
45 /* forward declarations */
46 struct bifcxdef;
47
48 /*
49 * Create a new object
50 */
run_new(runcxdef * ctx,uchar * noreg * codepp,objnum callobj,prpnum callprop)51 static void run_new(runcxdef *ctx, uchar *noreg *codepp,
52 objnum callobj, prpnum callprop)
53 {
54 objnum sc;
55 objnum objn;
56 objdef *objp;
57 int sccnt;
58 vocidef *voci;
59
60 /* get the superclass (nil means no superclass) */
61 if (runtostyp(ctx) == DAT_NIL)
62 sccnt = 0;
63 else
64 {
65 /* get the superclass */
66 sc = runpopobj(ctx);
67 sccnt = 1;
68
69 /* make sure it's not a dynamically-allocated object */
70 voci = vocinh(ctx->runcxvoc, sc);
71 if (voci->vociflg & VOCIFNEW)
72 runsig(ctx, ERR_BADNEWSC);
73 }
74
75 /* create a new object and set its superclass */
76 objp = objnew(ctx->runcxmem, sccnt, 64, &objn, FALSE);
77 if (sccnt) oswp2(objsc(objp), sc);
78
79 /* save undo for the object creation */
80 vocdusave_newobj(ctx->runcxvoc, objn);
81
82 /* touch and unlock the object */
83 mcmtch(ctx->runcxmem, (mcmon)objn);
84 mcmunlck(ctx->runcxmem, (mcmon)objn);
85
86 /* add a vocabulary inheritance record for the new object */
87 vociadd(ctx->runcxvoc, objn, MCMONINV, sccnt, &sc, VOCIFNEW | VOCIFVOC);
88
89 /* set up its vocabulary, inheriting from the class */
90 if (sccnt)
91 supivoc1((struct supcxdef *)0, ctx->runcxvoc,
92 vocinh(ctx->runcxvoc, objn), objn, TRUE, VOCFNEW);
93
94 /* run the constructor */
95 runpprop(ctx, codepp, callobj, callprop, objn, PRP_CONSTRUCT,
96 FALSE, 0, objn);
97 #ifdef NEVER
98 /*
99 * add it to its location's contents list by calling
100 * newobj.moveInto(newobj.location)
101 */
102 runppr(ctx, objn, PRP_LOCATION, 0);
103 if (runtostyp(ctx) == DAT_OBJECT)
104 runppr(ctx, objn, PRP_MOVEINTO, 1);
105 else
106 rundisc(ctx);
107 #endif
108
109 /* return the new object */
110 runpobj(ctx, objn);
111 }
112
113 /*
114 * Delete an object
115 */
run_delete(runcxdef * ctx,uchar * noreg * codepp,objnum callobj,prpnum callprop)116 static void run_delete(runcxdef *ctx, uchar *noreg *codepp,
117 objnum callobj, prpnum callprop)
118 {
119 objnum objn;
120 vocidef *voci;
121 int i;
122 voccxdef *vctx = ctx->runcxvoc;
123
124 /* get the object to be deleted */
125 objn = runpopobj(ctx);
126
127 /* make sure it was allocated with "new" */
128 voci = vocinh(vctx, objn);
129 if (voci == 0 || !(voci->vociflg & VOCIFNEW))
130 runsig(ctx, ERR_BADDEL);
131
132 /* run the destructor */
133 runpprop(ctx, codepp, callobj, callprop, objn, PRP_DESTRUCT,
134 FALSE, 0, objn);
135 #ifdef NEVER
136 /* remove it from its location, if any, by using moveInto(nil) */
137 runpnil(ctx);
138 runppr(ctx, objn, PRP_MOVEINTO, 1);
139 #endif
140
141 /* save undo for the object deletion */
142 vocdusave_delobj(vctx, objn);
143
144 /* delete the object's inheritance and vocabulary records */
145 vocdel(vctx, objn);
146 vocidel(vctx, objn);
147
148 /* forget 'it' if the deleted object is 'it' (or 'them', etc) */
149 if (vctx->voccxit == objn) vctx->voccxit = MCMONINV;
150 if (vctx->voccxhim == objn) vctx->voccxhim = MCMONINV;
151 if (vctx->voccxher == objn) vctx->voccxher = MCMONINV;
152 for (i = 0 ; i < vctx->voccxthc ; ++i)
153 {
154 if (vctx->voccxthm[i] == objn)
155 {
156 /* forget the entire 'them' list when deleting from it */
157 vctx->voccxthc = 0;
158 break;
159 }
160 }
161
162 /* forget the 'again' statistics if necessary */
163 if (vctx->voccxlsd.vocolobj == objn
164 || vctx->voccxlsi.vocolobj == objn
165 || vctx->voccxlsa == objn
166 || vctx->voccxlsv == objn
167 || vctx->voccxlsp == objn)
168 {
169 /* forget the verb */
170 vctx->voccxlsv = MCMONINV;
171
172 /*
173 * note in the flags why we lost the "again" verb, for better
174 * error reporting if the player tries to type "again"
175 */
176 vctx->voccxflg |= VOCCXAGAINDEL;
177 }
178
179 /* delete the memory manager object */
180 mcmfre(ctx->runcxmem, (mcmon)objn);
181 }
182
183
184 /*
185 * invoke a function
186 */
runfn(runcxdef * ctx,noreg objnum objn,int argc)187 void runfn(runcxdef *ctx, noreg objnum objn, int argc)
188 {
189 uchar *fn;
190 int err;
191
192 NOREG((&objn))
193
194 /* get a lock on the object */
195 fn = mcmlck(ctx->runcxmem, objn);
196
197 /* catch any errors, so we can unlock the object */
198 ERRBEGIN(ctx->runcxerr)
199
200 /* execute the object */
201 runexe(ctx, fn, MCMONINV, objn, (prpnum)0, argc);
202
203 /* in case of error, unlock the object and resignal the error */
204 ERRCATCH(ctx->runcxerr, err)
205 mcmunlck(ctx->runcxmem, objn); /* release the lock on the object */
206 if (err < ERR_RUNEXIT || err > ERR_RUNEXITOBJ)
207 dbgdump(ctx->runcxdbg); /* dump the stack */
208 errrse(ctx->runcxerr);
209 ERREND(ctx->runcxerr)
210
211 /* we're done with the object, so unlock it */
212 mcmunlck(ctx->runcxmem, objn);
213 }
214
215 /*
216 * compress the heap - remove unreferenced items
217 */
runhcmp(runcxdef * ctx,uint siz,uint below,runsdef * val1,runsdef * val2,runsdef * val3)218 void runhcmp(runcxdef *ctx, uint siz, uint below,
219 runsdef *val1, runsdef *val2, runsdef *val3)
220 {
221 uchar *hp = ctx->runcxheap;
222 uchar *htop = ctx->runcxhp;
223 runsdef *stop = ctx->runcxsp + below;
224 runsdef *stk = ctx->runcxstk;
225 runsdef *sp;
226 uchar *dst = hp;
227 uchar *hnxt;
228 int ref;
229
230 /* go through heap, finding references on stack */
231 for ( ; hp < htop ; hp = hnxt)
232 {
233 hnxt = hp + osrp2(hp); /* remember next heap element */
234
235 for (ref = FALSE, sp = stk ; sp < stop ; ++sp)
236 {
237 switch(sp->runstyp)
238 {
239 case DAT_SSTRING:
240 case DAT_LIST:
241 if (sp->runsv.runsvstr == hp) /* reference to this item? */
242 {
243 ref = TRUE; /* this heap item is referenced */
244 sp->runsv.runsvstr = dst; /* reflect imminent move */
245 }
246 break;
247
248 default: /* other types do not refer to the heap */
249 break;
250 }
251 }
252
253 /* check the explicitly referenced value pointers as well */
254 #define CHECK_VAL(val) \
255 if (val && val->runsv.runsvstr == hp) \
256 ref = TRUE, val->runsv.runsvstr = dst;
257 CHECK_VAL(val1);
258 CHECK_VAL(val2);
259 CHECK_VAL(val3);
260 #undef CHECK_VAL
261
262 /* if referenced, copy it to dst and advance dst */
263 if (ref)
264 {
265 if (hp != dst) memmove(dst, hp, (size_t)osrp2(hp));
266 dst += osrp2(dst);
267 }
268 }
269
270 /* set heap pointer based on shuffled heap */
271 ctx->runcxhp = dst;
272
273 /* check for space requested, and signal error if not available */
274 if ((uint)(ctx->runcxhtop - ctx->runcxhp) < siz)
275 runsig(ctx, ERR_HPOVF);
276 }
277
278 /*
279 * push a value onto the stack that's already been allocated in heap
280 */
runrepush(runcxdef * ctx,runsdef * val)281 void runrepush(runcxdef *ctx, runsdef *val)
282 {
283 /* check for stack overflow */
284 runstkovf(ctx);
285
286 OSCPYSTRUCT(*(ctx->runcxsp), *val);
287
288 /* increment stack pointer */
289 ++(ctx->runcxsp);
290 }
291
292 /* push a counted-length string onto the stack */
runpstr(runcxdef * ctx,char * str,int len,int sav)293 void runpstr(runcxdef *ctx, char *str, int len, int sav)
294 {
295 runsdef val;
296
297 /* allocate space and set up new string */
298 runhres(ctx, len+2, sav);
299 oswp2(ctx->runcxhp, len+2);
300 memcpy(ctx->runcxhp+2, str, (size_t)len);
301
302 /* push return value */
303 val.runsv.runsvstr = ctx->runcxhp;
304 val.runstyp = DAT_SSTRING;
305 ctx->runcxhp += len + 2;
306 runrepush(ctx, &val);
307 }
308
309 /* push a C-style string, converting escape codes */
runpushcstr(runcxdef * ctx,char * str,size_t len,int sav)310 void runpushcstr(runcxdef *ctx, char *str, size_t len, int sav)
311 {
312 char *p;
313 char *dst;
314 size_t need;
315 runsdef val;
316
317 /* determine how much space we'll need after converting escapes */
318 for (p = str, need = len ; p < str + len ; ++p)
319 {
320 switch(*p)
321 {
322 case '\\':
323 case '\n':
324 case '\r':
325 case '\t':
326 /* these characters need to be escaped */
327 ++need;
328 break;
329
330 default:
331 break;
332 }
333 }
334
335 /* reserve space */
336 runhres(ctx, need + 2, sav);
337
338 /* set up the length prefix */
339 oswp2(ctx->runcxhp, need + 2);
340
341 /* copy the string, expanding escapes */
342 for (p = str, dst = (char *)ctx->runcxhp + 2 ; p < str + len ; ++p)
343 {
344 switch(*p)
345 {
346 case '\\':
347 *dst++ = '\\';
348 *dst++ = '\\';
349 break;
350
351 case '\n':
352 case '\r':
353 *dst++ = '\\';
354 *dst++ = 'n';
355 break;
356
357 case '\t':
358 *dst++ = '\\';
359 *dst++ = '\t';
360 break;
361
362 default:
363 *dst++ = *p;
364 break;
365 }
366 }
367
368 /* push the return value */
369 val.runsv.runsvstr = ctx->runcxhp;
370 val.runstyp = DAT_SSTRING;
371 ctx->runcxhp += need + 2;
372 runrepush(ctx, &val);
373 }
374
375 /* push a value onto the stack */
runpush(runcxdef * ctx,dattyp typ,runsdef * val)376 void runpush(runcxdef *ctx, dattyp typ, runsdef *val)
377 {
378 int len;
379
380 /* check for stack overflow */
381 runstkovf(ctx);
382
383 OSCPYSTRUCT(*(ctx->runcxsp), *val);
384 ctx->runcxsp->runstyp = typ;
385
386 /* variable-length data must be copied into the heap */
387 if (typ == DAT_SSTRING || typ == DAT_LIST)
388 {
389 len = osrp2(val->runsv.runsvstr);
390 runhres(ctx, len, 0); /* reserve space in heap */
391 memcpy(ctx->runcxhp, val->runsv.runsvstr, (size_t)len);
392 ctx->runcxsp->runsv.runsvstr = ctx->runcxhp;
393 ctx->runcxhp += len;
394 }
395
396 /* increment stack pointer */
397 ++(ctx->runcxsp);
398 }
399
400 /* push a number onto the stack */
runpnum(runcxdef * ctx,long num)401 void runpnum(runcxdef *ctx, long num)
402 {
403 runsdef val;
404
405 val.runsv.runsvnum = num;
406 runpush(ctx, DAT_NUMBER, &val);
407 }
408
409 /* push an object onto the stack (or nil if obj is MCMONINV) */
runpobj(runcxdef * ctx,objnum obj)410 void runpobj(runcxdef *ctx, objnum obj)
411 {
412 runsdef val;
413
414 if (obj == MCMONINV)
415 runpnil(ctx);
416 else
417 {
418 val.runsv.runsvobj = obj;
419 runpush(ctx, DAT_OBJECT, &val);
420 }
421 }
422
423 /* push nil */
runpnil(runcxdef * ctx)424 void runpnil(runcxdef *ctx)
425 {
426 runsdef val;
427 runpush(ctx, DAT_NIL, &val);
428 }
429
430 /* copy datatype + value from a runsdef into a buffer (such as list) */
runputbuf(uchar * dstp,runsdef * val)431 static void runputbuf(uchar *dstp, runsdef *val)
432 {
433 *dstp++ = val->runstyp;
434 switch(val->runstyp)
435 {
436 case DAT_LIST:
437 case DAT_SSTRING:
438 memcpy(dstp, val->runsv.runsvstr, (size_t)osrp2(val->runsv.runsvstr));
439 break;
440
441 case DAT_NUMBER:
442 oswp4(dstp, val->runsv.runsvnum);
443 break;
444
445 case DAT_PROPNUM:
446 oswp2(dstp, val->runsv.runsvprp);
447 break;
448
449 case DAT_OBJECT:
450 case DAT_FNADDR:
451 oswp2(dstp, val->runsv.runsvobj);
452 break;
453 }
454 }
455
456 /* push a value from a buffer (list, property, etc) onto stack */
runpbuf(runcxdef * ctx,int typ,void * valp)457 void runpbuf(runcxdef *ctx, int typ, void *valp)
458 {
459 runsdef val;
460
461 switch(typ)
462 {
463 case DAT_NUMBER:
464 val.runsv.runsvnum = osrp4(valp);
465 break;
466
467 case DAT_OBJECT:
468 case DAT_FNADDR:
469 val.runsv.runsvobj = osrp2(valp);
470 break;
471
472 case DAT_PROPNUM:
473 val.runsv.runsvprp = osrp2(valp);
474 break;
475
476 case DAT_SSTRING:
477 case DAT_LIST:
478 val.runsv.runsvstr = (uchar *)valp;
479 break;
480
481 case DAT_NIL:
482 case DAT_TRUE:
483 break;
484 }
485 runpush(ctx, typ, &val);
486 }
487
488 /* compare items at top of stack for equality; TRUE->equal, FALSE->unequal */
runeq(runcxdef * ctx)489 int runeq(runcxdef *ctx)
490 {
491 runsdef val1, val2;
492
493 /* get values, and see if they have identical type; not equal if not */
494 runpop(ctx, &val1);
495 runpop(ctx, &val2);
496 if (val1.runstyp != val2.runstyp) return(FALSE);
497
498 /* types match, so check values */
499 switch(val1.runstyp)
500 {
501 case DAT_NUMBER:
502 return(val1.runsv.runsvnum == val2.runsv.runsvnum);
503
504 case DAT_SSTRING:
505 case DAT_LIST:
506 return(osrp2(val1.runsv.runsvstr) == osrp2(val2.runsv.runsvstr)
507 && !memcmp(val1.runsv.runsvstr, val2.runsv.runsvstr,
508 (size_t)osrp2(val1.runsv.runsvstr)));
509
510 case DAT_PROPNUM:
511 return(val1.runsv.runsvprp == val2.runsv.runsvprp);
512
513 case DAT_OBJECT:
514 case DAT_FNADDR:
515 return(val1.runsv.runsvobj == val2.runsv.runsvobj);
516
517 default:
518 return(TRUE);
519 }
520 }
521
522 /* compare magnitudes of numbers/strings at top of stack; strcmp-like value */
runmcmp(runcxdef * ctx)523 int runmcmp(runcxdef *ctx)
524 {
525 if (runtostyp(ctx) == DAT_NUMBER)
526 {
527 long num2 = runpopnum(ctx);
528 long num1 = runpopnum(ctx);
529
530 if (num1 > num2) return(1);
531 else if (num1 < num2) return(-1);
532 else return(0);
533 }
534 else if (runtostyp(ctx) == DAT_SSTRING)
535 {
536 uchar *str2 = runpopstr(ctx);
537 uchar *str1 = runpopstr(ctx);
538 uint len1 = osrp2(str1) - 2;
539 uint len2 = osrp2(str2) - 2;
540
541 str1 += 2;
542 str2 += 2;
543 while (len1 && len2)
544 {
545 if (*str1 < *str2) return(-1); /* character from 1 is greater */
546 else if (*str1 > *str2) return(1); /* char from 1 is less */
547
548 ++str1;
549 ++str2;
550 --len1;
551 --len2;
552 }
553 if (len1) return(1); /* match up to len2, but string 1 is longer */
554 else if (len2) return(-1); /* match up to len1, but str2 is longer */
555 else return(0); /* strings are identical */
556 }
557 else
558 {
559 runsig(ctx, ERR_INVCMP);
560 }
561 return 0;
562 }
563
564 /* determine size of a runsdef item */
runsiz(runsdef * item)565 int runsiz(runsdef *item)
566 {
567 switch(item->runstyp)
568 {
569 case DAT_NUMBER:
570 return(4);
571 case DAT_SSTRING:
572 case DAT_LIST:
573 return(osrp2(item->runsv.runsvstr));
574 case DAT_PROPNUM:
575 case DAT_OBJECT:
576 case DAT_FNADDR:
577 return(2);
578 default:
579 return(0);
580 }
581 }
582
583 /* find a sublist within a list */
runfind(uchar * lst,runsdef * item)584 uchar *runfind(uchar *lst, runsdef *item)
585 {
586 uint len;
587 uint curlen;
588
589 for (len = osrp2(lst) - 2, lst += 2 ; len ; lst += curlen, len -= curlen)
590 {
591 if (*lst == item->runstyp)
592 {
593 switch(*lst)
594 {
595 case DAT_LIST:
596 case DAT_SSTRING:
597 if (osrp2(lst+1) == osrp2(item->runsv.runsvstr) &&
598 !memcmp(lst+1, item->runsv.runsvstr, (size_t)osrp2(lst+1)))
599 return(lst);
600 break;
601 case DAT_NUMBER:
602 if (osrp4(lst+1) == item->runsv.runsvnum)
603 return(lst);
604 break;
605
606 case DAT_TRUE:
607 case DAT_NIL:
608 return(lst);
609
610 case DAT_OBJECT:
611 case DAT_FNADDR:
612 if (osrp2(lst+1) == item->runsv.runsvobj)
613 return(lst);
614 break;
615
616 case DAT_PROPNUM:
617 if (osrp2(lst+1) == item->runsv.runsvprp)
618 return(lst);
619 break;
620 }
621 }
622 curlen = datsiz(*lst, lst+1) + 1;
623 }
624 return((uchar *)0);
625 }
626
627 /* add values */
runadd(runcxdef * ctx,runsdef * val,runsdef * val2,uint below)628 void runadd(runcxdef *ctx, runsdef *val, runsdef *val2, uint below)
629 {
630 if (val->runstyp == DAT_LIST)
631 {
632 int len1 = osrp2(val->runsv.runsvstr);
633 int len2 = runsiz(val2);
634 int newlen;
635
636 /* if concatenating a list, take out length + datatype from 2nd */
637 if (val2->runstyp == DAT_LIST)
638 newlen = len1 + len2 - 2; /* leave out second list len */
639 else
640 newlen = len1 + len2 + 1; /* add in datatype header */
641
642 /* get space in heap, copy first list, and set new length */
643 runhres2(ctx, newlen, below, val, val2);
644 memcpy(ctx->runcxhp, val->runsv.runsvstr, (size_t)len1);
645 oswp2(ctx->runcxhp, newlen);
646
647 /* append the new element or list of elements */
648 if (val2->runstyp == DAT_LIST)
649 memcpy(ctx->runcxhp + len1, val2->runsv.runsvstr + 2,
650 (size_t)(len2 - 2));
651 else
652 runputbuf(ctx->runcxhp + len1, val2);
653
654 /* set up return value and update heap pointer */
655 val->runsv.runsvstr = ctx->runcxhp;
656 ctx->runcxhp += newlen;
657 }
658 else if (val->runstyp==DAT_SSTRING && val2->runstyp==DAT_SSTRING)
659 {
660 int len1 = osrp2(val->runsv.runsvstr);
661 int len2 = osrp2(val2->runsv.runsvstr);
662
663 /* reserve space, and concatenate the two strings */
664 runhres2(ctx, len1 + len2 - 2, below, val, val2);
665 memcpy(ctx->runcxhp, val->runsv.runsvstr, (size_t)len1);
666 memcpy(ctx->runcxhp + len1, val2->runsv.runsvstr + 2,
667 (size_t)len2 - 2);
668
669 /* set length to sum of two lengths, minus 2nd length word */
670 oswp2(ctx->runcxhp, len1 + len2 - 2);
671 val->runsv.runsvstr = ctx->runcxhp;
672 ctx->runcxhp += len1 + len2 - 2;
673 }
674 else if (val->runstyp == DAT_NUMBER && val2->runstyp == DAT_NUMBER)
675 val->runsv.runsvnum += val2->runsv.runsvnum;
676 else
677 runsig(ctx, ERR_INVADD);
678 }
679
680 /* returns TRUE if value changed */
runsub(runcxdef * ctx,runsdef * val,runsdef * val2,uint below)681 int runsub(runcxdef *ctx, runsdef *val, runsdef *val2, uint below)
682 {
683 if (val->runstyp == DAT_LIST)
684 {
685 uchar *sublist;
686 int subsize;
687 int listsize;
688 int part1sz;
689
690 if (val2->runstyp == DAT_LIST)
691 {
692 uchar *p1;
693 uchar *p2;
694 uint rem1;
695 uint rem2;
696 uchar *dst;
697
698 /* reserve space for another copy of first list */
699 listsize = runsiz(val);
700 runhres2(ctx, listsize, below, val, val2);
701 dst = ctx->runcxhp + 2;
702
703 /* get pointer to first list */
704 p1 = val->runsv.runsvstr;
705 rem1 = osrp2(p1) - 2;
706 p1 += 2;
707
708 /*
709 * loop through left list, copying elements to output if
710 * not in the right list
711 */
712 for ( ; rem1 ; lstadv(&p1, &rem1))
713 {
714 int found = FALSE;
715
716 /* find current element of first list in second list */
717 p2 = val2->runsv.runsvstr;
718 rem2 = osrp2(p2) - 2;
719 p2 += 2;
720 for ( ; rem2 ; lstadv(&p2, &rem2))
721 {
722 if (*p1 == *p2)
723 {
724 int siz1 = datsiz(*p1, p1+1);
725 int siz2 = datsiz(*p2, p2+1);
726
727 if (siz1 == siz2 &&
728 (siz1 == 0 || !memcmp(p1+1, p2+1, (size_t)siz1)))
729 {
730 found = TRUE;
731 break;
732 }
733 }
734 }
735
736 /* if this element wasn't found, copy to output list */
737 if (!found)
738 {
739 uint siz;
740
741 *dst++ = *p1;
742 if ((siz = datsiz(*p1, p1+1)) != 0)
743 {
744 memcpy(dst, p1+1, siz);
745 dst += siz;
746 }
747 }
748 }
749
750 /* we've built the list; write size and we're done */
751 oswp2(ctx->runcxhp, dst - ctx->runcxhp);
752 val->runsv.runsvstr = ctx->runcxhp;
753 ctx->runcxhp = dst;
754 }
755 else if ((sublist = runfind(val->runsv.runsvstr, val2)) != 0)
756 {
757 subsize = datsiz(*sublist, sublist + 1) + 1;
758 listsize = runsiz(val);
759 part1sz = sublist - (uchar *)val->runsv.runsvstr;
760
761 runhres2(ctx, listsize - subsize, below, val, val2);
762 memcpy(ctx->runcxhp, val->runsv.runsvstr, (size_t)part1sz);
763 memcpy(ctx->runcxhp + part1sz, sublist + subsize,
764 (size_t)(listsize - subsize - part1sz));
765 oswp2(ctx->runcxhp, listsize - subsize);
766 val->runsv.runsvstr = ctx->runcxhp;
767 ctx->runcxhp += listsize - subsize;
768 }
769 else
770 {
771 return(FALSE); /* no change - value can be re-pushed */
772 }
773 }
774 else if (val->runstyp == DAT_NUMBER && val2->runstyp == DAT_NUMBER)
775 val->runsv.runsvnum -= val2->runsv.runsvnum;
776 else
777 runsig(ctx, ERR_INVSUB);
778
779 return(TRUE); /* value has changed; must be pushed anew */
780 }
781
782 /* return code pointer offset */
runcpsav(runcxdef * ctx,uchar * noreg * cp,objnum obj,prpnum prop)783 static uint runcpsav(runcxdef *ctx, uchar *noreg *cp, objnum obj, prpnum prop)
784 {
785 uint ofs;
786
787 VARUSED(prop);
788
789 /* get offset from start of object */
790 ofs = *cp - mcmobjptr(ctx->runcxmem, (mcmon)obj);
791
792 /* clear the pointer so the caller knows the object is unlocked */
793 *cp = 0;
794
795 /* unlock the object, and return the derived offset */
796 mcmunlck(ctx->runcxmem, (mcmon)obj);
797 return(ofs);
798 }
799
800 /* restore code pointer based on object.property */
runcprst(runcxdef * ctx,uint ofs,objnum obj,prpnum prop)801 uchar *runcprst(runcxdef *ctx, uint ofs, objnum obj, prpnum prop)
802 {
803 uchar *ptr;
804
805 VARUSED(prop);
806
807 /* lock object, and get pointer based on offset */
808 ptr = mcmlck(ctx->runcxmem, (mcmon)obj) + ofs;
809
810 return(ptr);
811 }
812
813 /* get offset of an element within a list */
runindofs(runcxdef * ctx,uint indx,uchar * lstp)814 static uint runindofs(runcxdef *ctx, uint indx, uchar *lstp)
815 {
816 uint lstsiz;
817 uchar *orgp = lstp;
818
819 /* verify that index is in range */
820 if (indx <= 0) runsig(ctx, ERR_LOWINX);
821
822 /* get list's size, and point to its data string */
823 lstsiz = osrp2(lstp) - 2;
824 lstp += 2;
825
826 /* skip the first indx-1 elements */
827 for (--indx ; indx && lstsiz ; --indx) lstadv(&lstp, &lstsiz);
828
829 /* if we ran out of list, the index is out of range */
830 if (!lstsiz) runsig(ctx, ERR_HIGHINX);
831
832 /* return the offset */
833 return((uint)(lstp - orgp));
834 }
835
836 /* push an indexed element of a list; index is tos, list is next on stack */
runpind(runcxdef * ctx,uint indx,uchar * lstp)837 static void runpind(runcxdef *ctx, uint indx, uchar *lstp)
838 {
839 uchar *ele;
840 runsdef val;
841
842 /* find the element we want to push */
843 ele = lstp + runindofs(ctx, indx, lstp);
844
845 /* reserve space first, in case lstp gets moved around */
846 val.runstyp = DAT_LIST;
847 val.runsv.runsvstr = lstp;
848 runhres1(ctx, datsiz(*ele, ele + 1), 0, &val);
849 if (val.runsv.runsvstr != lstp)
850 ele = val.runsv.runsvstr + runindofs(ctx, indx, val.runsv.runsvstr);
851
852 /* push the operand */
853 runpbuf(ctx, *ele, ele+1);
854 }
855
856 /*
857 * Check a property to ensure that it's a data property. Throws an
858 * error if the property contains a method. This is used for debugger
859 * speculative evaluation to ensure that we don't call any methods from
860 * within speculative expressions.
861 */
runcheckpropdata(runcxdef * ctx,objnum obj,prpnum prop)862 static void runcheckpropdata(runcxdef *ctx, objnum obj, prpnum prop)
863 {
864 uint pofs;
865 objnum target;
866 objdef *objptr;
867 prpdef *prpptr;
868 int typ;
869
870 /* if the object is invalid, it's an error */
871 if (obj == MCMONINV)
872 errsig(ctx->runcxerr, ERR_REQVOB);
873
874 /* get the property */
875 pofs = objgetap(ctx->runcxmem, obj, prop, &target, FALSE);
876
877 /* if there's no property, it's okay - it will just return nil */
878 if (pofs == 0)
879 return;
880
881 /* get the object */
882 objptr = mcmlck(ctx->runcxmem, target);
883
884 /* get the property */
885 prpptr = (prpdef *)(((uchar *)objptr) + pofs);
886 typ = prptype(prpptr);
887
888 /* we're done with the object's memory now */
889 mcmunlck(ctx->runcxmem, target);
890
891 /* check the type */
892 switch(typ)
893 {
894 case DAT_CODE:
895 case DAT_DSTRING:
896 /*
897 * we can't call code or evaluate (i.e., print) double-quoted
898 * strings during speculative evaluation
899 */
900 errsig(ctx->runcxerr, ERR_RTBADSPECEXPR);
901
902 default:
903 /* other types do not involve method calls, so they're okay */
904 break;
905 }
906 }
907
908 /* push an object's property */
runpprop(runcxdef * ctx,uchar * noreg * codepp,objnum callobj,prpnum callprop,noreg objnum obj,prpnum prop,int inh,int argc,objnum self)909 void runpprop(runcxdef *ctx, uchar *noreg *codepp,
910 objnum callobj, prpnum callprop,
911 noreg objnum obj, prpnum prop, int inh, int argc, objnum self)
912 {
913 uint pofs;
914 uint saveofs;
915 objdef *objptr;
916 prpdef *prpptr;
917 uchar *val;
918 int typ;
919 runsdef sval;
920 objnum target;
921 int times_through = 0;
922 int err;
923 objnum otherobj;
924
925 NOREG((&obj, &codepp));
926
927 if (obj == MCMONINV) runsig(ctx, ERR_RUNNOBJ);
928
929 startover:
930 pofs = objgetap(ctx->runcxmem, obj, prop, &target, inh);
931
932 /* if nothing was found, push nil */
933 if (!pofs)
934 {
935 runpush(ctx, DAT_NIL, &sval);
936 return;
937 }
938
939 /* found a property; get the prpdef, and the value and type of data */
940 objptr = mcmlck(ctx->runcxmem, target);
941 ERRBEGIN(ctx->runcxerr) /* catch errors so we can unlock object */
942
943 prpptr = (prpdef *)(((uchar *)objptr) + pofs);
944 val = prpvalp(prpptr);
945 typ = prptype(prpptr);
946
947 /* determine what to do based on property type */
948 switch(typ)
949 {
950 case DAT_CODE:
951 /* save caller's code offset - caller's object may move */
952 if (codepp)
953 saveofs = runcpsav(ctx, codepp, callobj, callprop);
954
955 /* execute the code */
956 runexe(ctx, val, self, target, prop, argc);
957
958 /* restore caller's code pointer in case object moved */
959 if (codepp)
960 *codepp = runcprst(ctx, saveofs, callobj, callprop);
961 break;
962
963 case DAT_REDIR:
964 otherobj = osrp2(val);
965 break;
966
967 case DAT_DSTRING:
968 outfmt(ctx->runcxtio, val);
969 break;
970
971 case DAT_DEMAND:
972 break;
973
974 default:
975 runpbuf(ctx, typ, val);
976 break;
977 }
978
979 /* we're done - unlock the object */
980 mcmunlck(ctx->runcxmem, target);
981
982 /* if it's redirected, redirect it now */
983 if (typ == DAT_REDIR)
984 {
985 runpprop(ctx, codepp, callobj, callprop, otherobj, prop,
986 FALSE, argc, otherobj);
987 }
988
989 /* if an error occurs, unlock the object, and resignal the error */
990 ERRCATCH(ctx->runcxerr, err)
991 mcmunlck(ctx->runcxmem, target);
992 if (err < ERR_RUNEXIT || err > ERR_RUNEXITOBJ)
993 dbgdump(ctx->runcxdbg); /* dump the stack */
994 errrse(ctx->runcxerr);
995 ERREND(ctx->runcxerr)
996
997 /* apply special handling for set-on-first-use data */
998 if (typ == DAT_DEMAND)
999 {
1000 /*
1001 * if we've already done this, the property isn't being set by
1002 * the callback, so we'll never get out of this loop - abort if
1003 * so
1004 */
1005 if (++times_through != 1)
1006 runsig(ctx, ERR_DMDLOOP);
1007
1008 /* save caller's code offset - caller's object may move */
1009 if (codepp)
1010 saveofs = runcpsav(ctx, codepp, callobj, callprop);
1011
1012 /* invoke the callback to set the property on demand */
1013 (*ctx->runcxdmd)(ctx->runcxdmc, obj, prop);
1014
1015 /* restore caller's code pointer */
1016 if (codepp)
1017 *codepp = runcprst(ctx, saveofs, callobj, callprop);
1018
1019 /* try again now that it's been set up */
1020 goto startover;
1021 }
1022 }
1023
1024 /* ======================================================================== */
1025 /*
1026 * user exit callbacks
1027 */
1028
runuftyp(runuxdef * ctx)1029 static int runuftyp(runuxdef *ctx)
1030 {
1031 return(runtostyp(ctx->runuxctx));
1032 }
1033
runufnpo(runuxdef * ctx)1034 static long runufnpo(runuxdef *ctx)
1035 {
1036 return(runpopnum(ctx->runuxctx));
1037 }
1038
runufspo(runuxdef * ctx)1039 static uchar *runufspo(runuxdef *ctx)
1040 {
1041 return(runpopstr(ctx->runuxctx));
1042 }
1043
runufdsc(runuxdef * ctx)1044 static void runufdsc(runuxdef *ctx)
1045 {
1046 rundisc(ctx->runuxctx);
1047 }
1048
runufnpu(runuxdef * ctx,long num)1049 static void runufnpu(runuxdef *ctx, long num)
1050 {
1051 runpnum(ctx->runuxctx, num);
1052 }
1053
runufspu(runuxdef * ctx,uchar * str)1054 static void runufspu(runuxdef *ctx, uchar *str)
1055 {
1056 runsdef val;
1057
1058 val.runstyp = DAT_SSTRING;
1059 val.runsv.runsvstr = str - 2;
1060 runrepush(ctx->runuxctx, &val);
1061 }
1062
runufcspu(runuxdef * ctx,char * str)1063 static void runufcspu(runuxdef *ctx, char *str)
1064 {
1065 runpstr(ctx->runuxctx, str, (int)strlen(str), ctx->runuxargc);
1066 }
1067
runufsal(runuxdef * ctx,int len)1068 static uchar *runufsal(runuxdef *ctx, int len)
1069 {
1070 uchar *ret;
1071
1072 len += 2;
1073 runhres(ctx->runuxctx, len, ctx->runuxargc);
1074 ret = ctx->runuxctx->runcxhp;
1075 oswp2(ret, len);
1076 ret += 2;
1077
1078 ctx->runuxctx->runcxhp += len;
1079 return(ret);
1080 }
1081
runuflpu(runuxdef * ctx,int typ)1082 static void runuflpu(runuxdef *ctx, int typ)
1083 {
1084 runsdef val;
1085
1086 val.runstyp = typ;
1087 runrepush(ctx->runuxctx, &val);
1088 }
1089
1090
1091
1092 /* convert an osrp2 value to a signed short value */
1093 #define runrp2s(p) ((short)(ushort)osrp2(p))
1094
1095
1096 /* ======================================================================== */
1097 /*
1098 * execute p-code
1099 */
runexe(runcxdef * ctx,uchar * p0,objnum self,objnum target,prpnum targprop,int argc)1100 void runexe(runcxdef *ctx, uchar *p0, objnum self, objnum target,
1101 prpnum targprop, int argc)
1102 {
1103 uchar *noreg p = p0;
1104 uchar opc; /* opcode we're currently working on */
1105 runsdef val; /* stack element (for pushing) */
1106 runsdef val2; /* another one (for popping in two-op instructions) */
1107 uint ofs; /* offset in code of current execution */
1108 prpnum prop; /* property number, when needed */
1109 objnum obj; /* object number, when needed */
1110 runsdef *noreg rstsp; /* sp to reset to on DISCARD instructions */
1111 uchar *lstp; /* list pointer */
1112 int nargc; /* argument count of called function */
1113 runsdef *valp;
1114 runsdef *stkval;
1115 int i;
1116 int brkchk;
1117
1118 #ifndef DBG_OFF
1119 int err;
1120 #endif
1121
1122 NOREG((&rstp, &p));
1123
1124 /* save entry SP - this is reset point until ENTER */
1125 rstsp = ctx->runcxsp;
1126
1127 #ifndef DBG_OFF
1128 /*
1129 * For the debugger's sake, set up an error frame so that we catch
1130 * any errors thrown during p-code execution within this function.
1131 * If an error occurs, and the debugger is present, we'll set the
1132 * instruction pointer back to the start of the line that caused the
1133 * error and enter the debugger with the error indication. If the
1134 * debugger isn't present, we'll simply re-throw the error. This
1135 * entire block can be compiled out of the execution engine when
1136 * linking a stand-alone (non-debug) version of the run-time.
1137 */
1138 resume_from_error:
1139 ERRBEGIN(ctx->runcxerr)
1140 #endif /* DBG_OFF */
1141
1142 for (brkchk = 0 ;; ++brkchk)
1143 {
1144 /* check for break - signal if user has hit break */
1145 if (brkchk == 1000)
1146 {
1147 brkchk = 0;
1148 if (os_break()) runsig(ctx, ERR_USRINT);
1149 }
1150
1151 opc = *p++;
1152
1153 switch(opc)
1154 {
1155 case OPCPUSHNUM:
1156 val.runsv.runsvnum = osrp4(p);
1157 runpush(ctx, DAT_NUMBER, &val);
1158 p += 4;
1159 break;
1160
1161 case OPCPUSHOBJ:
1162 val.runsv.runsvobj = osrp2(p);
1163 runpush(ctx, DAT_OBJECT, &val);
1164 p += 2;
1165 break;
1166
1167 case OPCPUSHSELF:
1168 val.runsv.runsvobj = self;
1169 runpush(ctx, DAT_OBJECT, &val);
1170 break;
1171
1172 case OPCPUSHSTR:
1173 val.runsv.runsvstr = p;
1174 runpush(ctx, DAT_SSTRING, &val);
1175 p += osrp2(p); /* skip past string */
1176 break;
1177
1178 case OPCPUSHLST:
1179 val.runsv.runsvstr = p;
1180 runpush(ctx, DAT_LIST, &val);
1181 p += osrp2(p); /* skip past list */
1182 break;
1183
1184 case OPCPUSHNIL:
1185 runpush(ctx, DAT_NIL, &val);
1186 break;
1187
1188 case OPCPUSHTRUE:
1189 runpush(ctx, DAT_TRUE, &val);
1190 break;
1191
1192 case OPCPUSHFN:
1193 val.runsv.runsvobj = osrp2(p);
1194 runpush(ctx, DAT_FNADDR, &val);
1195 p += 2;
1196 break;
1197
1198 case OPCPUSHPN:
1199 val.runsv.runsvprp = osrp2(p);
1200 runpush(ctx, DAT_PROPNUM, &val);
1201 p += 2;
1202 break;
1203
1204 case OPCNEG:
1205 val.runstyp = DAT_NUMBER;
1206 val.runsv.runsvnum = -runpopnum(ctx);
1207 runrepush(ctx, &val);
1208 break;
1209
1210 case OPCBNOT:
1211 val.runstyp = DAT_NUMBER;
1212 val.runsv.runsvnum = ~runpopnum(ctx);
1213 runrepush(ctx, &val);
1214 break;
1215
1216 case OPCNOT:
1217 if (runtoslog(ctx))
1218 runpush(ctx, runclog(!runpoplog(ctx)), &val);
1219 else
1220 runpush(ctx, runclog(runpopnum(ctx)), &val);
1221 break;
1222
1223 case OPCADD:
1224 runpop(ctx, &val2); /* right op is pushed last -> popped 1st */
1225 runpop(ctx, &val);
1226 runadd(ctx, &val, &val2, 2);
1227 runrepush(ctx, &val);
1228 break;
1229
1230 case OPCSUB:
1231 runpop(ctx, &val2); /* right op is pushed last -> popped 1st */
1232 runpop(ctx, &val);
1233 (void)runsub(ctx, &val, &val2, 2);
1234 runrepush(ctx, &val);
1235 break;
1236
1237 case OPCMUL:
1238 val.runstyp = DAT_NUMBER;
1239 val.runsv.runsvnum = runpopnum(ctx) * runpopnum(ctx);
1240 runrepush(ctx, &val);
1241 break;
1242
1243 case OPCBAND:
1244 val.runstyp = DAT_NUMBER;
1245 val.runsv.runsvnum = runpopnum(ctx) & runpopnum(ctx);
1246 runrepush(ctx, &val);
1247 break;
1248
1249 case OPCBOR:
1250 val.runstyp = DAT_NUMBER;
1251 val.runsv.runsvnum = runpopnum(ctx) | runpopnum(ctx);
1252 runrepush(ctx, &val);
1253 break;
1254
1255 case OPCSHL:
1256 val.runstyp = DAT_NUMBER;
1257 val.runsv.runsvnum = runpopnum(ctx);
1258 val.runsv.runsvnum = runpopnum(ctx) << val.runsv.runsvnum;
1259 runrepush(ctx, &val);
1260 break;
1261
1262 case OPCSHR:
1263 val.runstyp = DAT_NUMBER;
1264 val.runsv.runsvnum = runpopnum(ctx);
1265 val.runsv.runsvnum = runpopnum(ctx) >> val.runsv.runsvnum;
1266 runrepush(ctx, &val);
1267 break;
1268
1269 case OPCXOR:
1270 /* allow logical ^ logical or number ^ number */
1271 if (runtoslog(ctx))
1272 {
1273 int a, b;
1274
1275 /* logicals - return a logical value */
1276 a = runpoplog(ctx);
1277 b = runpoplog(ctx);
1278 val.runstyp = runclog(a ^ b);
1279 }
1280 else
1281 {
1282 /* numeric value - return binary xor */
1283 val.runstyp = DAT_NUMBER;
1284 val.runsv.runsvnum = runpopnum(ctx) ^ runpopnum(ctx);
1285 }
1286 runrepush(ctx, &val);
1287 break;
1288
1289 case OPCDIV:
1290 val.runsv.runsvnum = runpopnum(ctx);
1291 if (val.runsv.runsvnum == 0)
1292 runsig(ctx, ERR_DIVZERO);
1293 val.runsv.runsvnum = runpopnum(ctx) / val.runsv.runsvnum;
1294 val.runstyp = DAT_NUMBER;
1295 runrepush(ctx, &val);
1296 break;
1297
1298 case OPCMOD:
1299 val.runsv.runsvnum = runpopnum(ctx);
1300 if (val.runsv.runsvnum == 0)
1301 runsig(ctx, ERR_DIVZERO);
1302 val.runsv.runsvnum = runpopnum(ctx) % val.runsv.runsvnum;
1303 val.runstyp = DAT_NUMBER;
1304 runrepush(ctx, &val);
1305 break;
1306
1307 #ifdef NEVER
1308 case OPCAND:
1309 if (runtostyp(ctx) == DAT_LIST)
1310 runlstisect(ctx);
1311 else
1312 runpush(ctx, runclog(runpoplog(ctx) && runpoplog(ctx)), &val);
1313 break;
1314
1315 case OPCOR:
1316 runpush(ctx, runclog(runpoplog(ctx) || runpoplog(ctx)), &val);
1317 break;
1318 #endif /* NEVER */
1319
1320 case OPCEQ:
1321 runpush(ctx, runclog(runeq(ctx)), &val);
1322 break;
1323
1324 case OPCNE:
1325 runpush(ctx, runclog(!runeq(ctx)), &val);
1326 break;
1327
1328 case OPCLT:
1329 runpush(ctx, runclog(runmcmp(ctx) < 0), &val);
1330 break;
1331
1332 case OPCLE:
1333 runpush(ctx, runclog(runmcmp(ctx) <= 0), &val);
1334 break;
1335
1336 case OPCGT:
1337 runpush(ctx, runclog(runmcmp(ctx) > 0), &val);
1338 break;
1339
1340 case OPCGE:
1341 runpush(ctx, runclog(runmcmp(ctx) >= 0), &val);
1342 break;
1343
1344 case OPCCALL:
1345 {
1346 objnum o;
1347
1348 /* get the argument count */
1349 nargc = *p++;
1350
1351 /* ensure we have enough values to pass as arguments */
1352 runcheckargc(ctx, &nargc);
1353
1354 /* object could move--save offset to restore 'p' after call */
1355 o = osrp2(p);
1356 ofs = runcpsav(ctx, &p, target, targprop);
1357
1358 /* execute the function */
1359 runfn(ctx, o, nargc);
1360
1361 /* restore code pointer in case target object moved */
1362 p = runcprst(ctx, ofs, target, targprop) + 2;
1363 break;
1364 }
1365
1366 case OPCGETP:
1367 nargc = *p++;
1368 runcheckargc(ctx, &nargc);
1369 prop = osrp2(p);
1370 p += 2;
1371 obj = runpopobj(ctx);
1372 runpprop(ctx, &p, target, targprop, obj, prop, FALSE, nargc,
1373 obj);
1374 break;
1375
1376 case OPCGETPDATA:
1377 prop = osrp2(p);
1378 p += 2;
1379 obj = runpopobj(ctx);
1380 runcheckpropdata(ctx, obj, prop);
1381 runpprop(ctx, &p, target, targprop, obj, prop, FALSE, 0, obj);
1382 break;
1383
1384 case OPCGETDBLCL:
1385 {
1386 objnum frobj;
1387 uint frofs;
1388 runsdef *otherbp;
1389
1390 frobj = osrp2(p);
1391 frofs = osrp2(p + 2);
1392 otherbp = dbgfrfind(ctx->runcxdbg, frobj, frofs);
1393 runrepush(ctx, otherbp + runrp2s(p + 4) - 1);
1394 p += 6;
1395 }
1396 break;
1397
1398 case OPCGETLCL:
1399 runrepush(ctx, ctx->runcxbp + runrp2s(p) - 1);
1400 p += 2;
1401 break;
1402
1403 case OPCRETURN:
1404 runleave(ctx, argc /* was: osrp2(p) */);
1405 dbgleave(ctx->runcxdbg, DBGEXRET);
1406 goto done;
1407
1408 case OPCRETVAL:
1409 /* if there's nothing on the stack, return nil */
1410 if (runtostyp(ctx) != DAT_BASEPTR)
1411 runpop(ctx, &val);
1412 else
1413 val.runstyp = DAT_NIL;
1414
1415 runleave(ctx, argc /* was: osrp2(p) */);
1416 runrepush(ctx, &val);
1417 dbgleave(ctx->runcxdbg, DBGEXVAL);
1418 goto done;
1419
1420 case OPCENTER:
1421 /* push old base pointer and set up new one */
1422 ctx->runcxsp = rstsp;
1423 val.runsv.runsvstr = (uchar *)ctx->runcxbp;
1424 runpush(ctx, DAT_BASEPTR, &val);
1425 ctx->runcxbp = ctx->runcxsp;
1426
1427 /* add a trace record */
1428 dbgenter(ctx->runcxdbg, ctx->runcxbp, self, target, targprop,
1429 0, argc);
1430
1431 /* initialize locals to nil */
1432 for (i = osrp2(p) ; i ; --i) runpush(ctx, DAT_NIL, &val);
1433 p += 2; /* skip the local count operand */
1434
1435 /* save stack pointer - reset sp to this value on DISCARD */
1436 rstsp = ctx->runcxsp;
1437 break;
1438
1439 case OPCDISCARD:
1440 ctx->runcxsp = rstsp;
1441 break;
1442
1443 case OPCSWITCH:
1444 {
1445 int i;
1446 int tostyp;
1447 int match, typmatch;
1448
1449 runpop(ctx, &val);
1450 tostyp = val.runstyp;
1451 switch(tostyp)
1452 {
1453 case DAT_SSTRING:
1454 tostyp = OPCPUSHSTR;
1455 break;
1456 case DAT_LIST:
1457 tostyp = OPCPUSHLST;
1458 break;
1459 case DAT_PROPNUM:
1460 tostyp = OPCPUSHPN;
1461 break;
1462 case DAT_FNADDR:
1463 tostyp = OPCPUSHFN;
1464 break;
1465 case DAT_TRUE:
1466 tostyp = OPCPUSHTRUE;
1467 break;
1468 case DAT_NIL:
1469 tostyp = OPCPUSHNIL;
1470 break;
1471 }
1472
1473 p += osrp2(p); /* find the switch table */
1474 i = osrp2(p); /* get number of cases */
1475
1476 /* look for a matching case */
1477 for (match = FALSE ; i && !match ; --i)
1478 {
1479 p += 2; /* skip previous jump/size word */
1480 typmatch = (*p == tostyp);
1481 switch(*p++)
1482 {
1483 case OPCPUSHNUM:
1484 match = (typmatch
1485 && val.runsv.runsvnum == osrp4(p));
1486 p += 4;
1487 break;
1488
1489 case OPCPUSHLST:
1490 case OPCPUSHSTR:
1491 match = (typmatch
1492 && osrp2(val.runsv.runsvstr) == osrp2(p)
1493 && !memcmp(val.runsv.runsvstr,
1494 p, (size_t)osrp2(p)));
1495 p += runrp2s(p);
1496 break;
1497
1498 case OPCPUSHPN:
1499 match = (typmatch
1500 && val.runsv.runsvprp == osrp2(p));
1501 p += 2;
1502 break;
1503
1504 case OPCPUSHOBJ:
1505 case OPCPUSHFN:
1506 match = (typmatch
1507 && val.runsv.runsvobj == osrp2(p));
1508 p += 2;
1509 break;
1510
1511 case OPCPUSHSELF:
1512 match = (typmatch && val.runsv.runsvobj == self);
1513 break;
1514
1515 case OPCPUSHTRUE:
1516 case OPCPUSHNIL:
1517 match = typmatch;
1518 break;
1519 }
1520 }
1521
1522 if (!match) p += 2; /* if default, skip to default case */
1523 p += runrp2s(p); /* wherever we left off, p points to jump */
1524 break;
1525 }
1526
1527 case OPCJMP:
1528 p += runrp2s(p);
1529 break;
1530
1531 case OPCJT:
1532 if (runtoslog(ctx))
1533 p += (runpoplog(ctx) ? runrp2s(p) : 2);
1534 else
1535 p += (runpopnum(ctx) != 0 ? runrp2s(p) : 2);
1536 break;
1537
1538 case OPCJF:
1539 if (runtoslog(ctx))
1540 p += ((!runpoplog(ctx)) ? runrp2s(p) : 2);
1541 else if (runtostyp(ctx) == DAT_NUMBER)
1542 p += ((runpopnum(ctx) == 0) ? runrp2s(p) : 2);
1543 else /* consider any other type to be true */
1544 {
1545 rundisc(ctx); /* throw away the item considered to be true */
1546 p += 2;
1547 }
1548 break;
1549
1550 case OPCSAY:
1551 outfmt(ctx->runcxtio, p);
1552 p += osrp2(p); /* skip past string */
1553 break;
1554
1555 case OPCBUILTIN:
1556 {
1557 int binum;
1558 runsdef *stkp;
1559
1560 nargc = *p++;
1561 runcheckargc(ctx, &nargc);
1562 binum = osrp2(p);
1563 ofs = runcpsav(ctx, &p, target, targprop);
1564 stkp = ctx->runcxsp - nargc;
1565
1566 dbgenter(ctx->runcxdbg, ctx->runcxsp + 1, MCMONINV, MCMONINV,
1567 (prpnum)0, binum, nargc);
1568 (*ctx->runcxbi[binum])((struct bifcxdef *)ctx->runcxbcx,
1569 nargc);
1570 dbgleave(ctx->runcxdbg,
1571 ctx->runcxsp != stkp ? DBGEXVAL : DBGEXRET);
1572
1573 p = runcprst(ctx, ofs, target, targprop);
1574 p += 2;
1575 break;
1576 }
1577
1578 case OPCPTRCALL:
1579 nargc = *p++;
1580 runcheckargc(ctx, &nargc);
1581 ofs = runcpsav(ctx, &p, target, targprop);
1582 runfn(ctx, runpopfn(ctx), nargc);
1583 p = runcprst(ctx, ofs, target, targprop);
1584 break;
1585
1586 case OPCINHERIT:
1587 nargc = *p++;
1588 runcheckargc(ctx, &nargc);
1589 prop = osrp2(p);
1590 p += 2;
1591 runpprop(ctx, &p, target, targprop, target, prop, TRUE, nargc,
1592 self);
1593 break;
1594
1595 case OPCPTRINH:
1596 nargc = *p++;
1597 runcheckargc(ctx, &nargc);
1598 prop = runpopprp(ctx);
1599 runpprop(ctx, &p, target, targprop, target, prop, TRUE, nargc,
1600 self);
1601 break;
1602
1603 case OPCPTRGETP:
1604 nargc = *p++;
1605 runcheckargc(ctx, &nargc);
1606 prop = runpopprp(ctx);
1607 obj = runpopobj(ctx);
1608 runpprop(ctx, &p, target, targprop, obj, prop, FALSE, nargc,
1609 obj);
1610 break;
1611
1612 case OPCPTRGETPDATA:
1613 prop = runpopprp(ctx);
1614 obj = runpopobj(ctx);
1615 runcheckpropdata(ctx, obj, prop);
1616 runpprop(ctx, &p, target, targprop, obj, prop, FALSE, 0, obj);
1617 break;
1618
1619 case OPCEXPINH:
1620 /* inheritance from explicit superclass */
1621 nargc = *p++;
1622 runcheckargc(ctx, &nargc);
1623 prop = osrp2(p);
1624 obj = osrp2(p + 2);
1625 p += 4;
1626
1627 /*
1628 * Evaluate the property of the given object, but keeping
1629 * the same 'self' as is currently in effect. Note that the
1630 * 'inherit' flag is FALSE in this call, even though we're
1631 * inheriting, because the opcode explicitly specifies the
1632 * object we want to inherit from.
1633 */
1634 runpprop(ctx, &p, target, targprop, obj, prop, FALSE,
1635 nargc, self);
1636 break;
1637
1638 case OPCEXPINHPTR:
1639 nargc = *p++;
1640 runcheckargc(ctx, &nargc);
1641 prop = runpopprp(ctx);
1642 obj = osrp2(p);
1643 p += 2;
1644 runpprop(ctx, &p, target, targprop, obj, prop, FALSE,
1645 nargc, self);
1646 break;
1647
1648 case OPCPASS:
1649 prop = osrp2(p);
1650 runleave(ctx, 0);
1651 dbgleave(ctx->runcxdbg, DBGEXPASS);
1652 runpprop(ctx, &p, target, targprop, target, prop, TRUE, argc,
1653 self);
1654 goto done;
1655
1656 case OPCEXIT:
1657 errsig(ctx->runcxerr, ERR_RUNEXIT);
1658 /* NOTREACHED */
1659
1660 case OPCABORT:
1661 errsig(ctx->runcxerr, ERR_RUNABRT);
1662 /* NOTREACHED */
1663
1664 case OPCASKDO:
1665 errsig(ctx->runcxerr, ERR_RUNASKD);
1666 /* NOTREACHED */
1667
1668 case OPCASKIO:
1669 errsig1(ctx->runcxerr, ERR_RUNASKI, ERRTINT, osrp2(p));
1670 /* NOTREACHED */
1671
1672 case OPCJE:
1673 p += (runeq(ctx) ? runrp2s(p) : 2);
1674 break;
1675
1676 case OPCJNE:
1677 p += (!runeq(ctx) ? runrp2s(p) : 2);
1678 break;
1679
1680 case OPCJGT:
1681 p += (runmcmp(ctx) > 0 ? runrp2s(p) : 2);
1682 break;
1683
1684 case OPCJGE:
1685 p += (runmcmp(ctx) >= 0 ? runrp2s(p) : 2);
1686 break;
1687
1688 case OPCJLT:
1689 p += (runmcmp(ctx) < 0 ? runrp2s(p) : 2);
1690 break;
1691
1692 case OPCJLE:
1693 p += (runmcmp(ctx) <= 0 ? runrp2s(p) : 2);
1694 break;
1695
1696 case OPCJNAND:
1697 p += (!(runpoplog(ctx) && runpoplog(ctx)) ? runrp2s(p) : 2);
1698 break;
1699
1700 case OPCJNOR:
1701 p += (!(runpoplog(ctx) || runpoplog(ctx)) ? runrp2s(p) : 2);
1702 break;
1703
1704 case OPCGETPSELF:
1705 nargc = *p++;
1706 runcheckargc(ctx, &nargc);
1707 prop = osrp2(p);
1708 p += 2;
1709 runpprop(ctx, &p, target, targprop, self, prop, FALSE, nargc,
1710 self);
1711 break;
1712
1713 case OPCGETPSELFDATA:
1714 prop = osrp2(p);
1715 p += 2;
1716 runcheckpropdata(ctx, self, prop);
1717 runpprop(ctx, &p, target, targprop, self, prop, FALSE, 0, self);
1718 break;
1719
1720 case OPCGETPPTRSELF:
1721 nargc = *p++;
1722 runcheckargc(ctx, &nargc);
1723 prop = runpopprp(ctx);
1724 runpprop(ctx, &p, target, targprop, self, prop, FALSE, nargc,
1725 self);
1726 break;
1727
1728 case OPCGETPOBJ:
1729 nargc = *p++;
1730 runcheckargc(ctx, &nargc);
1731 obj = osrp2(p);
1732 prop = osrp2(p+2);
1733 p += 4;
1734 runpprop(ctx, &p, target, targprop, obj, prop, FALSE, nargc,
1735 obj);
1736 break;
1737
1738 case OPCINDEX:
1739 i = runpopnum(ctx); /* get index */
1740 lstp = runpoplst(ctx); /* get the list */
1741 runpind(ctx, i, lstp);
1742 break;
1743
1744 case OPCJST:
1745 if (runtostyp(ctx) == DAT_TRUE)
1746 p += runrp2s(p);
1747 else
1748 {
1749 (void)runpoplog(ctx);
1750 p += 2;
1751 }
1752 break;
1753
1754 case OPCJSF:
1755 if (runtostyp(ctx) == DAT_NIL ||
1756 (runtostyp(ctx) == DAT_NUMBER &&
1757 (ctx->runcxsp - 1)->runsv.runsvnum == 0))
1758 p += runrp2s(p);
1759 else
1760 {
1761 runpop(ctx, &val);
1762 p += 2;
1763 }
1764 break;
1765
1766 case OPCCALLEXT:
1767 {
1768 static runufdef uf =
1769 {
1770 runuftyp, runufnpo, runufspo, runufdsc,
1771 runufnpu, runufspu, runufcspu, runufsal,
1772 runuflpu
1773 };
1774 int fn;
1775 runxdef *ex;
1776 runuxdef ux;
1777
1778 /* set up callback context */
1779 ux.runuxctx = ctx;
1780 ux.runuxvec = &uf;
1781 ux.runuxargc = *p++;
1782
1783 fn = osrp2(p);
1784 p += 2;
1785 ex = &ctx->runcxext[fn];
1786
1787 #if 0
1788 /*
1789 * External functions are now obsolete - do not attempt to call
1790 */
1791 if (!ex->runxptr)
1792 {
1793 if ((ex->runxptr = os_exfil(ex->runxnam)) == 0)
1794 runsig1(ctx, ERR_EXTLOAD, ERRTSTR, ex->runxnam);
1795 }
1796 if (os_excall(ex->runxptr, &ux))
1797 runsig1(ctx, ERR_EXTRUN, ERRTSTR, ex->runxnam);
1798 #else
1799 /* external functions are obsolete - throw an error */
1800 runsig1(ctx, ERR_EXTRUN, ERRTSTR, ex->runxnam);
1801 #endif
1802 }
1803 break;
1804
1805 case OPCDBGRET:
1806 goto done;
1807
1808 case OPCCONS:
1809 {
1810 uint totsiz;
1811 uint oldsiz;
1812 uint tot;
1813 uint cursiz;
1814 runsdef lstend;
1815
1816 tot = i = osrp2(p); /* get # of items to build into list */
1817 p += 2;
1818
1819 /* reserve space for initial list (w/length word only) */
1820 runhres(ctx, 2, 0);
1821
1822 /*
1823 * Set up value to point to output list, making room
1824 * for length prefix. Remember size-so-far separately.
1825 */
1826 lstend.runstyp = DAT_LIST;
1827 lstend.runsv.runsvstr = ctx->runcxhp;
1828 ctx->runcxhp += 2;
1829 totsiz = 2;
1830
1831 while (i--)
1832 {
1833 runpop(ctx, &val); /* get next value off stack */
1834 cursiz = runsiz(&val);
1835
1836 /*
1837 * Set up to allocate space. Before doing so, make
1838 * sure the list under construction is valid, to
1839 * ensure that it stays around after garbage
1840 * collection.
1841 */
1842 oldsiz = totsiz;
1843 totsiz += cursiz + 1;
1844 oswp2(lstend.runsv.runsvstr, oldsiz);
1845 ctx->runcxhp = lstend.runsv.runsvstr + oldsiz;
1846 runhres2(ctx, cursiz + 1, tot - i, &val, &lstend);
1847
1848 /* write this item to the list */
1849 runputbuf(lstend.runsv.runsvstr + oldsiz, &val);
1850 }
1851 oswp2(lstend.runsv.runsvstr, totsiz);
1852 ctx->runcxhp = lstend.runsv.runsvstr + totsiz;
1853 runrepush(ctx, &lstend);
1854 }
1855 break;
1856
1857 case OPCARGC:
1858 val.runsv.runsvnum = argc;
1859 runpush(ctx, DAT_NUMBER, &val);
1860 break;
1861
1862 case OPCCHKARGC:
1863 if ((*p & 0x80) ? argc < (*p & 0x7f) : argc != *p)
1864 {
1865 char namebuf[128];
1866 size_t namelen;
1867
1868 /*
1869 * debugger is present - look up the name of the current
1870 * function or method, so that we can report it in the
1871 * error message
1872 */
1873 if (targprop == 0)
1874 {
1875 /* we're in a function */
1876 namelen = dbgnam(ctx->runcxdbg, namebuf, TOKSTFUNC,
1877 target);
1878 }
1879 else
1880 {
1881 /* we're in an object.method */
1882 namelen = dbgnam(ctx->runcxdbg, namebuf, TOKSTOBJ,
1883 target);
1884 namebuf[namelen++] = '.';
1885 namelen += dbgnam(ctx->runcxdbg, namebuf + namelen,
1886 TOKSTPROP, targprop);
1887 }
1888 namebuf[namelen] = '\0';
1889 runsig1(ctx, ERR_ARGC, ERRTSTR, namebuf);
1890 }
1891 ++p;
1892 break;
1893
1894 case OPCLINE:
1895 case OPCBP:
1896 {
1897 uchar *ptr = mcmobjptr(ctx->runcxmem, (mcmon)target);
1898 uint ofs;
1899 uchar instr;
1900
1901 /* set up the debugger frame record for this line */
1902 dbgframe(ctx->runcxdbg, osrp2(p+1), p - ptr);
1903
1904 /* remember the instruction */
1905 instr = *(p-1);
1906
1907 /* remember the offset of the line record */
1908 ctx->runcxlofs = ofs = (p + 2 - ptr);
1909
1910 /* skip to the next instruction */
1911 p += *p;
1912
1913 /* let the debugger take over, if it wants to */
1914 dbgssi(ctx->runcxdbg, ofs, instr, 0, &p);
1915 break;
1916 }
1917
1918 case OPCFRAME:
1919 /* this is a frame record - just jump past it */
1920 p += osrp2(p);
1921 break;
1922
1923 case OPCASI_MASK | OPCASIDIR | OPCASILCL:
1924 runpop(ctx, &val);
1925 OSCPYSTRUCT(*(ctx->runcxbp + runrp2s(p) - 1), val);
1926 stkval = &val;
1927 p += 2;
1928 goto no_assign;
1929
1930 case OPCASI_MASK | OPCASIDIR | OPCASIPRP:
1931 obj = runpopobj(ctx);
1932 prop = osrp2(p);
1933 p += 2;
1934 runpop(ctx, &val);
1935 stkval = valp = &val;
1936 goto assign_property;
1937
1938 case OPCASI_MASK | OPCASIDIR | OPCASIPRPPTR:
1939 prop = runpopprp(ctx);
1940 obj = runpopobj(ctx);
1941 runpop(ctx, &val);
1942 stkval = valp = &val;
1943 goto assign_property;
1944
1945 case OPCNEW:
1946 run_new(ctx, &p, target, targprop);
1947 break;
1948
1949 case OPCDELETE:
1950 run_delete(ctx, &p, target, targprop);
1951 break;
1952
1953 default:
1954 if ((opc & OPCASI_MASK) == OPCASI_MASK)
1955 {
1956 runsdef val3;
1957 int asityp;
1958 int asiext;
1959 int lclnum;
1960
1961 valp = &val;
1962 stkval = &val;
1963
1964 asityp = (opc & OPCASITYP_MASK);
1965 if (asityp == OPCASIEXT)
1966 asiext = *p++;
1967
1968 /* get list element/property number if needed */
1969 switch(opc & OPCASIDEST_MASK)
1970 {
1971 case OPCASIPRP:
1972 obj = runpopobj(ctx);
1973 prop = osrp2(p);
1974 p += 2;
1975 break;
1976
1977 case OPCASIPRPPTR:
1978 prop = runpopprp(ctx);
1979 obj = runpopobj(ctx);
1980 break;
1981
1982 case OPCASIIND:
1983 i = runpopnum(ctx);
1984 lstp = runpoplst(ctx);
1985 break;
1986
1987 case OPCASILCL:
1988 lclnum = runrp2s(p);
1989 p += 2;
1990 break;
1991 }
1992
1993 if (asityp != OPCASIDIR)
1994 {
1995 /* we have an <op>= operator - get lval, modify, & set */
1996 switch(opc & OPCASIDEST_MASK)
1997 {
1998 case OPCASILCL:
1999 OSCPYSTRUCT(val, *(ctx->runcxbp + lclnum - 1));
2000 break;
2001
2002 case OPCASIPRP:
2003 case OPCASIPRPPTR:
2004 runpprop(ctx, &p, target, targprop, obj, prop,
2005 FALSE, 0, obj);
2006 runpop(ctx, &val);
2007 break;
2008
2009 case OPCASIIND:
2010 runpind(ctx, i, lstp);
2011 runpop(ctx, &val);
2012 break;
2013 }
2014
2015 /* if saving pre-inc/dec value, get the value now */
2016 if ((opc & OPCASIPRE_MASK) == OPCASIPOST)
2017 {
2018 OSCPYSTRUCT(val3, val);
2019 stkval = &val3;
2020 }
2021 }
2022
2023 /* get rvalue, except for inc/dec operations */
2024 if (asityp != OPCASIINC && asityp != OPCASIDEC)
2025 runpop(ctx, &val2);
2026
2027 /* now apply operation to lvalue using rvalue */
2028 switch(asityp)
2029 {
2030 case OPCASIADD:
2031 if ((opc & OPCASIIND) != 0)
2032 {
2033 runsdef val4;
2034
2035 /*
2036 * we're adding to an indexed value out of a list -
2037 * we need to make sure the list is protected from
2038 * garbage collection, so push it back on the stack
2039 * while we're working
2040 */
2041 val4.runstyp = DAT_LIST;
2042 val4.runsv.runsvstr = lstp;
2043 runrepush(ctx, &val4);
2044
2045 /* carry out the addition */
2046 runadd(ctx, &val, &val2, 2);
2047
2048 /*
2049 * in case the list got moved during garbage
2050 * collection, retrieve it from the stack
2051 */
2052 lstp = runpoplst(ctx);
2053 }
2054 else
2055 {
2056 /* no list indexing - just carry out the addition */
2057 runadd(ctx, &val, &val2, 2);
2058 }
2059 break;
2060
2061 case OPCASISUB:
2062 if ((opc & OPCASIIND) != 0)
2063 {
2064 runsdef val4;
2065 int result;
2066
2067 /* as with adding, protect the list from GC */
2068 val4.runstyp = DAT_LIST;
2069 val4.runsv.runsvstr = lstp;
2070 runrepush(ctx, &val4);
2071
2072 /* carry out the subtraction and note the result */
2073 result = runsub(ctx, &val, &val2, 2);
2074
2075 /* recover the list pointer */
2076 lstp = runpoplst(ctx);
2077
2078 /* check to see if we have an assignment */
2079 if (!result)
2080 goto no_assign;
2081 }
2082 else
2083 {
2084 /* no list indexing - just do the subtraction */
2085 if (!runsub(ctx, &val, &val2, 2))
2086 goto no_assign;
2087 }
2088 break;
2089
2090 case OPCASIMUL:
2091 if (val.runstyp != DAT_NUMBER
2092 || val2.runstyp != DAT_NUMBER)
2093 runsig(ctx, ERR_REQNUM);
2094 val.runsv.runsvnum *= val2.runsv.runsvnum;
2095 break;
2096
2097 case OPCASIDIV:
2098 if (val.runstyp != DAT_NUMBER
2099 || val2.runstyp != DAT_NUMBER)
2100 runsig(ctx, ERR_REQNUM);
2101 if (val2.runsv.runsvnum == 0)
2102 runsig(ctx, ERR_DIVZERO);
2103 val.runsv.runsvnum /= val2.runsv.runsvnum;
2104 break;
2105
2106 case OPCASIINC:
2107 if (val.runstyp != DAT_NUMBER)
2108 runsig(ctx, ERR_REQNUM);
2109 ++(val.runsv.runsvnum);
2110 break;
2111
2112 case OPCASIDEC:
2113 if (val.runstyp != DAT_NUMBER)
2114 runsig(ctx, ERR_REQNUM);
2115 --(val.runsv.runsvnum);
2116 break;
2117
2118 case OPCASIDIR:
2119 valp = stkval = &val2;
2120 break;
2121
2122 case OPCASIEXT:
2123 switch (asiext)
2124 {
2125 case OPCASIMOD:
2126 if (val.runstyp != DAT_NUMBER
2127 || val2.runstyp != DAT_NUMBER)
2128 runsig(ctx, ERR_REQNUM);
2129 if (val2.runsv.runsvnum == 0)
2130 runsig(ctx, ERR_DIVZERO);
2131 val.runsv.runsvnum %= val2.runsv.runsvnum;
2132 break;
2133
2134 case OPCASIBAND:
2135 if ((val.runstyp == DAT_TRUE
2136 || val.runstyp == DAT_NIL)
2137 && (val2.runstyp == DAT_TRUE
2138 || val2.runstyp == DAT_NIL))
2139 {
2140 int a, b;
2141
2142 a = (val.runstyp == DAT_TRUE ? 1 : 0);
2143 b = (val2.runstyp == DAT_TRUE ? 1 : 0);
2144 val.runstyp = runclog(a && b);
2145 }
2146 else if (val.runstyp == DAT_NUMBER
2147 && val2.runstyp == DAT_NUMBER)
2148 val.runsv.runsvnum &= val2.runsv.runsvnum;
2149 else
2150 runsig(ctx, ERR_REQNUM);
2151 break;
2152
2153 case OPCASIBOR:
2154 if ((val.runstyp == DAT_TRUE
2155 || val.runstyp == DAT_NIL)
2156 && (val2.runstyp == DAT_TRUE
2157 || val2.runstyp == DAT_NIL))
2158 {
2159 int a, b;
2160
2161 a = (val.runstyp == DAT_TRUE ? 1 : 0);
2162 b = (val2.runstyp == DAT_TRUE ? 1 : 0);
2163 val.runstyp = runclog(a || b);
2164 }
2165 else if (val.runstyp == DAT_NUMBER
2166 && val2.runstyp == DAT_NUMBER)
2167 val.runsv.runsvnum |= val2.runsv.runsvnum;
2168 else
2169 runsig(ctx, ERR_REQNUM);
2170 break;
2171
2172 case OPCASIXOR:
2173 if ((val.runstyp == DAT_TRUE || val.runstyp == DAT_NIL)
2174 && (val2.runstyp == DAT_TRUE
2175 || val2.runstyp == DAT_NIL))
2176 {
2177 int a, b;
2178
2179 a = (val.runstyp == DAT_TRUE ? 1 : 0);
2180 b = (val2.runstyp == DAT_TRUE ? 1 : 0);
2181 val.runstyp = runclog(a ^ b);
2182 }
2183 else if (val.runstyp == DAT_NUMBER
2184 && val2.runstyp == DAT_NUMBER)
2185 val.runsv.runsvnum ^= val2.runsv.runsvnum;
2186 else
2187 runsig(ctx, ERR_REQNUM);
2188 break;
2189
2190 case OPCASISHL:
2191 if (val.runstyp != DAT_NUMBER
2192 || val2.runstyp != DAT_NUMBER)
2193 runsig(ctx, ERR_REQNUM);
2194 val.runsv.runsvnum <<= val2.runsv.runsvnum;
2195 break;
2196
2197 case OPCASISHR:
2198 if (val.runstyp != DAT_NUMBER
2199 || val2.runstyp != DAT_NUMBER)
2200 runsig(ctx, ERR_REQNUM);
2201 val.runsv.runsvnum >>= val2.runsv.runsvnum;
2202 break;
2203
2204 default:
2205 runsig(ctx, ERR_INVOPC);
2206 }
2207 break;
2208
2209 default:
2210 runsig(ctx, ERR_INVOPC);
2211 }
2212
2213 /* write the rvalue at *valp to the lvalue */
2214 switch(opc & OPCASIDEST_MASK)
2215 {
2216 case OPCASILCL:
2217 OSCPYSTRUCT(*(ctx->runcxbp + lclnum - 1), *valp);
2218 break;
2219
2220 case OPCASIPRP:
2221 case OPCASIPRPPTR:
2222 assign_property:
2223 {
2224 void *valbuf;
2225 uchar outbuf[4];
2226
2227 switch(valp->runstyp)
2228 {
2229 case DAT_LIST:
2230 case DAT_SSTRING:
2231 valbuf = valp->runsv.runsvstr;
2232 break;
2233
2234 case DAT_NUMBER:
2235 valbuf = outbuf;
2236 oswp4(outbuf, valp->runsv.runsvnum);
2237 break;
2238
2239 case DAT_OBJECT:
2240 case DAT_FNADDR:
2241 valbuf = outbuf;
2242 oswp2(outbuf, valp->runsv.runsvobj);
2243 break;
2244
2245 case DAT_PROPNUM:
2246 valbuf = outbuf;
2247 oswp2(outbuf, valp->runsv.runsvprp);
2248 break;
2249
2250 default:
2251 valbuf = &valp->runsv;
2252 break;
2253 }
2254
2255 ofs = runcpsav(ctx, &p, target, targprop);
2256 objsetp(ctx->runcxmem, obj, prop, valp->runstyp,
2257 valbuf, ctx->runcxundo);
2258 p = runcprst(ctx, ofs, target, targprop);
2259 break;
2260 }
2261
2262 case OPCASIIND:
2263 {
2264 uint newtot;
2265 uint newsiz;
2266 uint remsiz;
2267 uint delsiz;
2268 uchar *delp;
2269 uchar *remp;
2270
2271 /* compute sizes and pointers to various parts */
2272 ofs = runindofs(ctx, i, lstp);
2273 delp = lstp + ofs; /* ptr to item to replace */
2274 delsiz = datsiz(*delp, delp + 1); /* size of *delp */
2275 remsiz = osrp2(lstp) - ofs - delsiz - 1;
2276 newsiz = runsiz(valp); /* size of new item */
2277 newtot = osrp2(lstp) + newsiz - delsiz; /* new tot */
2278
2279 /* reserve space for the new list & copy first part */
2280 {
2281 runsdef val3;
2282
2283 /* make sure lstp stays valid before and after */
2284 val3.runstyp = DAT_LIST;
2285 val3.runsv.runsvstr = lstp;
2286 runhres3(ctx, newtot, 3, &val, &val2, &val3);
2287
2288 /* update all of the pointers within lstp */
2289 lstp = val3.runsv.runsvstr;
2290 delp = lstp + ofs;
2291 remp = lstp + ofs + delsiz + 1;
2292 }
2293 memcpy(ctx->runcxhp + 2, lstp + 2, (size_t)(ofs - 2));
2294
2295 /* set size of new list */
2296 oswp2(ctx->runcxhp, newtot);
2297
2298 /* copy new item into buffer */
2299 runputbuf(ctx->runcxhp + ofs, valp);
2300
2301 /* copy remainder and update heap pointer */
2302 memcpy(ctx->runcxhp + ofs + newsiz + 1, remp,
2303 (size_t)remsiz);
2304 val.runstyp = DAT_LIST;
2305 val.runsv.runsvstr = ctx->runcxhp;
2306 stkval = &val;
2307 ctx->runcxhp += newtot;
2308 break;
2309 }
2310 }
2311
2312 no_assign: /* skip assignment - operation didn't change value */
2313 if (*p == OPCDISCARD)
2314 {
2315 /* next assignment is DISCARD - deal with it now */
2316 ++p;
2317 ctx->runcxsp = rstsp;
2318 }
2319 else
2320 runrepush(ctx, stkval);
2321 }
2322 else
2323 errsig(ctx->runcxerr, ERR_INVOPC);
2324 }
2325 }
2326
2327 /*
2328 * come here to return - don't use 'return' directly, since that
2329 * would not properly exit the error frame
2330 */
2331 done: ;
2332
2333 #ifndef DBG_OFF
2334 /*
2335 * Come here to catch any errors that occur during execution of this
2336 * p-code
2337 */
2338 ERRCATCH(ctx->runcxerr, err)
2339 {
2340 /*
2341 * if the debugger isn't present, or we're already in the
2342 * debugger, or if the debugger can't resume from errors, or if
2343 * we're not in user code (in which case the debugger can't
2344 * resume from this error even if it normally could resume from
2345 * an error), simply re-signal the error
2346 */
2347 if (!dbgpresent()
2348 || ctx->runcxdbg->dbgcxfcn == 0
2349 || !dbgu_err_resume(ctx->runcxdbg)
2350 || (ctx->runcxdbg->dbgcxflg & DBGCXFIND) != 0)
2351 errrse(ctx->runcxerr);
2352
2353 /* check the error code */
2354 switch(err)
2355 {
2356 case ERR_RUNEXIT:
2357 case ERR_RUNABRT:
2358 case ERR_RUNASKD:
2359 case ERR_RUNASKI:
2360 case ERR_RUNQUIT:
2361 case ERR_RUNRESTART:
2362 case ERR_RUNEXITOBJ:
2363 /* don't trap these errors - resignal it immediately */
2364 errrse(ctx->runcxerr);
2365
2366 default:
2367 /* trap other errors to the debugger */
2368 break;
2369 }
2370
2371 /* if the object was unlocked, re-lock it */
2372 if (p == 0)
2373 mcmlck(ctx->runcxmem, target);
2374
2375 /* set up after the last OPCLINE instruction */
2376 p = mcmobjptr(ctx->runcxmem, (mcmon)target) + ctx->runcxlofs - 2;
2377 p += *p;
2378
2379 /*
2380 * Keep the current error's arguments around for handling
2381 * outside of this handler, since we'll need them in dbgssi.
2382 */
2383 errkeepargs(ctx->runcxerr);
2384
2385 /* enter the debugger with the error code */
2386 dbgssi(ctx->runcxdbg, ctx->runcxlofs, OPCLINE, err, &p);
2387
2388 /* check the error again */
2389 switch (err)
2390 {
2391 case ERR_ARGC:
2392 /* we can't continue from this - simply return */
2393 break;
2394
2395 default:
2396 /* resume execution */
2397 goto resume_from_error;
2398 }
2399 }
2400 ERREND(ctx->runcxerr);
2401 #endif /* DBG_OFF */
2402 }
2403
2404 /*
2405 * Signal a run-time error. This function first calls the debugger
2406 * single-step function to allow the debugger to trap the error, then
2407 * signals the error as usual when the debugger returns.
2408 */
runsign(runcxdef * ctx,int err)2409 void runsign(runcxdef *ctx, int err)
2410 {
2411 /*
2412 * If the debugger isn't capable of resuming from a run-time error,
2413 * trap to the debugger now so that the user can see what happened.
2414 * Do not trap to the debugger here if the debugger can resume from
2415 * an error; instead, we'll trap in the p-code loop, since we'll be
2416 * able to resume execution from the point of the error.
2417 *
2418 * Note that we can't resume from an error when there's no stack
2419 * frame, so we'll trap to the debugger here in that case.
2420 */
2421 if (ctx->runcxdbg->dbgcxfcn == 0
2422 || !dbgu_err_resume(ctx->runcxdbg))
2423 dbgssi(ctx->runcxdbg, ctx->runcxlofs, OPCLINE, err, 0);
2424
2425 /* signal the error */
2426 errsign(ctx->runcxerr, err, "TADS");
2427 }
2428
2429