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