1 /* ------------------------------------------------------------------------- */
2 /* "veneer" : Compiling the run-time "veneer" of any routines invoked */
3 /* by the compiler (e.g. DefArt) which the program doesn't */
6 /* Copyright (c) Graham Nelson 1993 - 2020 */
8 /* This file is part of Inform. */
10 /* Inform is free software: you can redistribute it and/or modify */
11 /* it under the terms of the GNU General Public License as published by */
12 /* the Free Software Foundation, either version 3 of the License, or */
13 /* (at your option) any later version. */
15 /* Inform is distributed in the hope that it will be useful, */
16 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
17 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
18 /* GNU General Public License for more details. */
20 /* You should have received a copy of the GNU General Public License */
21 /* along with Inform. If not, see https://gnu.org/licenses/ */
23 /* ------------------------------------------------------------------------- */
27 int veneer_mode; /* Is the code currently being
28 compiled from the veneer? */
30 static debug_locations null_debug_locations =
31 { { 0, 0, 0, 0, 0, 0, 0 }, NULL, 0 };
33 extern void compile_initial_routine(void)
35 /* The first routine present in memory in any Inform game, beginning
36 at the code area start position, always has 0 local variables
37 (since the interpreter begins execution with an empty stack frame):
38 and it must "quit" rather than "return".
40 In order not to impose these restrictions on "Main", we compile a
41 trivial routine consisting of a call to "Main" followed by "quit". */
46 j = symbol_index("Main__", -1);
48 assemble_routine_header(0, FALSE, "Main__", FALSE, j),
50 sflags[j] |= SYSTEM_SFLAG + USED_SFLAG;
51 if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG;
55 INITAOTV(&AO, LONG_CONSTANT_OT, 0);
58 sequence_point_follows = FALSE;
60 if (version_number > 3)
61 assemblez_1_to(call_vs_zc, AO, temp_var1);
63 assemblez_1_to(call_zc, AO, temp_var1);
70 INITAOTV(&AO, CONSTANT_OT, 0);
73 sequence_point_follows = FALSE;
75 assembleg_3(call_gc, AO, zero_operand, zero_operand);
76 assembleg_1(return_gc, zero_operand);
80 assemble_routine_end(FALSE, null_debug_locations);
83 /* ------------------------------------------------------------------------- */
84 /* The rest of the veneer is applied at the end of the pass, as required. */
85 /* ------------------------------------------------------------------------- */
87 static int veneer_routine_needs_compilation[VENEER_ROUTINES];
88 int32 veneer_routine_address[VENEER_ROUTINES];
89 static int veneer_symbols_base;
95 typedef struct VeneerRoutine_s
105 static char *veneer_source_area;
107 static VeneerRoutine VRs_z[VENEER_ROUTINES] =
109 /* Box__Routine: the only veneer routine used in the implementation of
110 an actual statement ("box", of course), written in a
111 hybrid of Inform and assembly language. Note the
112 transcription of the box text to the transcript
113 output stream (-1, or $ffff). */
116 "maxw table n w w2 line lc t;\
131 { @set_cursor line w;\
133 @set_cursor line w2;\
135 if (t~=0) print (string) t;\
144 @output_stream $ffff;\
149 if (w ~= 0) print (string) w;\
161 /* This batch of routines is expected to be defined (rather better) by
162 the Inform library: these minimal forms here are provided to prevent
163 tiny non-library-using programs from failing to compile when certain
164 legal syntaxes (such as <<Action a b>>;) are used. */
167 "a b c d; print \"Action <\", a, \" \", b, \" \", c;\
168 if (d) print \", \", d; print \">^\";\
169 ]", "", "", "", "", ""
172 "obj; print \"the \", obj; ]", "", "", "", "", ""
175 "obj; print \"a \", obj; ]", "", "", "", "", ""
178 "obj; print \"The \", obj; ]", "", "", "", "", ""
181 "obj; print \"A \", obj; ]", "", "", "", "", ""
184 "obj; switch(metaclass(obj))\
185 { 0: print \"nothing\";\
186 Object: @print_obj obj;\
187 Class: print \"class \"; @print_obj obj;\
188 Routine: print \"(routine at \", obj, \")\";\
189 String: print \"(string at \", obj, \")\";\
190 } ]", "", "", "", "", ""
193 "obj; print obj; ]", "", "", "", "", ""
198 { cla = #classes_table-->(prop & $ff);\
199 print (name) cla, \"::\";\
200 if ((prop & $8000) == 0) prop = (prop & $3f00)/$100;\
202 { prop = (prop & $7f00)/$100;\
204 while ((i-->0 ~= 0) && (prop>0))\
208 prop = (i-->0) & $7fff;\
211 "p = #identifiers_table;\
213 if (prop<=0 || prop>=size || p-->prop==0)\
214 print \"<number \", prop, \">\";\
215 else print (string) p-->prop;\
219 /* The remaining routines make up the run-time half of the object
220 orientation system, and need never be present for Inform 5 programs. */
223 /* WV__Pr: write a value to the property for the given
224 object having the given identifier */
227 "obj identifier value x;\
228 x = obj..&identifier;\
229 if (x==0) { RT__Err(\"write to\", obj, identifier); return; }\
231 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,value);\
232 #ifnot; #ifdef DEBUG;\
233 if (debug_flag & 15) RT__TrPS(obj,identifier,value);\
236 ]", "", "", "", "", ""
239 /* RV__Pr: read a value from the property for the given
240 object having the given identifier */
244 x = obj..&identifier;\
246 { if (identifier >= 1 && identifier < 64 && obj.#identifier <= 2)\
247 return obj.identifier;\
248 RT__Err(\"read\", obj, identifier); return; }\
250 if (obj..#identifier > 2) RT__Err(\"read\", obj, identifier);\
252 if (obj..#identifier > 2) RT__Err(\"read\", obj, identifier, 2);\
255 ]", "", "", "", "", ""
257 { /* CA__Pr: call, that is, print-or-run-or-read, a property:
258 this exactly implements obj..prop(...). Note that
259 classes (members of Class) have 5 built-in properties
260 inherited from Class: create, recreate, destroy,
261 remaining and copy. Implementing these here prevents
262 the need for a full metaclass inheritance scheme. */
265 "obj id a b c d e f x y z s s2 n m;\
266 if (obj < 1 || obj > #largest_object-255)\
267 { switch(Z__Region(obj))\
268 { 2: if (id == call)\
269 { s = sender; sender = self; self = obj;\
270 #ifdef action;sw__var=action;#endif;\
271 x = indirect(obj, a, b, c, d, e, f);\
272 self = sender; sender = s; return x; }\
274 "3: if (id == print) { @print_paddr obj; rtrue; }\
275 if (id == print_to_array)\
276 { @output_stream 3 a; @print_paddr obj; @output_stream -3;\
282 @check_arg_count 3 ?~A__x;y++;@check_arg_count 4 ?~A__x;y++;\
283 @check_arg_count 5 ?~A__x;y++;@check_arg_count 6 ?~A__x;y++;\
284 @check_arg_count 7 ?~A__x;y++;@check_arg_count 8 ?~A__x;y++;.A__x;",
285 "#ifdef INFIX;if (obj has infix__watching) n=1;#endif;\
286 #ifdef DEBUG;if (debug_flag & 1 ~= 0) n=1;#endif;\
288 #ifdef DEBUG;n=debug_flag & 1; debug_flag=debug_flag-n;#endif;\
289 print \"[ ~\", (name) obj, \"~.\", (property) id, \"(\";\
290 switch(y) { 1: print a; 2: print a,\",\",b; 3: print a,\",\",b,\",\",c;\
291 4: print a,\",\",b,\",\",c,\",\",d;\
292 5: print a,\",\",b,\",\",c,\",\",d,\",\",e;\
293 6: print a,\",\",b,\",\",c,\",\",d,\",\",e,\",\",f; }\
295 #ifdef DEBUG;debug_flag = debug_flag + n;#endif;\
297 "if (id > 0 && id < 64)\
298 { x = obj.&id; if (x==0) { x=$000a-->0 + 2*(id-1); n=2; }\
301 { if (id>=64 && id<69 && obj in Class)\
302 return Cl__Ms(obj,id,y,a,b,c,d);\
304 if (x == 0) { .Call__Error;\
305 RT__Err(\"send message\", obj, id); return; }\
307 if (id&$C000==$4000)\
308 switch (n&$C0) { 0: n=1; $40: n=2; $80: n=n&$3F; }\
311 { if (x-->m==$ffff) rfalse;\
312 switch(Z__Region(x-->m))\
313 { 2: s = sender; sender = self; self = obj; s2 = sw__var;\
315 if (id==life) sw__var=reason_code; else sw__var=action;\
317 switch(y) { 0: z = indirect(x-->m); 1: z = indirect(x-->m, a);\
318 2: z = indirect(x-->m, a, b); 3: z = indirect(x-->m, a, b, c);",
319 "4: z = indirect(x-->m, a, b, c, d); 5:z = indirect(x-->m, a, b, c, d, e);\
320 6: z = indirect(x-->m, a, b, c, d, e, f); }\
321 self = sender; sender = s; sw__var = s2;\
322 if (z ~= 0) return z;\
323 3: print_ret (string) x-->m;\
324 default: return x-->m;\
331 /* IB__Pr: ++(individual property) */
335 x = obj..&identifier;\
336 if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
338 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)+1);\
339 #ifnot; #ifdef DEBUG;\
340 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
343 ]", "", "", "", "", ""
346 /* IA__Pr: (individual property)++ */
350 x = obj..&identifier;\
351 if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
353 if (obj has infix__watching || (debug_flag & 15))\
354 RT__TrPS(obj,identifier,(x-->0)+1);\
355 #ifnot; #ifdef DEBUG;\
356 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
359 ]", "", "", "", "", ""
362 /* DB__Pr: --(individual property) */
366 x = obj..&identifier;\
367 if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
369 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
370 #ifnot; #ifdef DEBUG;\
371 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
374 ]", "", "", "", "", ""
377 /* DA__Pr: (individual property)-- */
381 x = obj..&identifier;\
382 if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
384 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
385 #ifnot; #ifdef DEBUG;\
386 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
389 ]", "", "", "", "", ""
392 /* RA__Pr: read the address of a property value for a given object,
393 returning 0 if it doesn't provide this individual
397 "obj identifier i otherid cla;\
399 if (identifier<64 && identifier>0) return obj.&identifier;\
400 if (identifier & $8000 ~= 0)\
401 { cla = #classes_table-->(identifier & $ff);\
402 if (cla.&3 == 0) rfalse;\
403 if (~~(obj ofclass cla)) rfalse;\
404 identifier = (identifier & $7f00) / $100;\
406 while (identifier>0)\
412 "if (identifier & $4000 ~= 0)\
413 { cla = #classes_table-->(identifier & $ff);\
414 identifier = (identifier & $3f00) / $100;\
415 if (~~(obj ofclass cla)) rfalse; i=0-->5;\
416 if (cla == 2) return i+2*identifier-2;\
417 i = 0-->((i+124+cla*14)/2);\
418 i = CP__Tab(i + 2*(0->i) + 1, -1)+6;\
419 return CP__Tab(i, identifier);\
421 if (obj.&3 == 0) rfalse;\
423 { if (identifier<64 || identifier>=72) rfalse;\
426 otherid = identifier | $8000;\
429 { if (i-->0 == identifier or otherid)\
437 /* RL__Pr: read the property length of an individual property value,
438 returning 0 if it isn't provided by the given object */
442 if (identifier<64 && identifier>0) return obj.#identifier;\
443 x = obj..&identifier;\
445 if (identifier&$C000==$4000)\
446 switch (((x-1)->0)&$C0)\
447 { 0: return 1; $40: return 2; $80: return ((x-1)->0)&$3F; }\
449 ]", "", "", "", "", ""
452 /* RA__Sc: implement the "superclass" (::) operator,
453 returning an identifier */
456 "cla identifier otherid i j k;\
457 if (cla notin 1 && cla > 4)\
458 { RT__Err(\"be a '::' superclass\", cla, -1); rfalse; }\
459 if (self ofclass cla) otherid = identifier | $8000;\
460 for (j=0: #classes_table-->j ~= 0: j++)\
461 { if (cla==#classes_table-->j)\
462 { if (identifier < 64) return $4000 + identifier*$100 + j;\
463 if (cla.&3 == 0) break;\
466 { if (i-->0 == identifier or otherid)\
467 return $8000 + k*$100 + j;\
474 RT__Err(\"make use of\", cla, identifier);\
479 /* OP__Pr: test whether or not given object provides individual
480 property with the given identifier code */
484 if (obj<1 || obj > (#largest_object-255))\
485 { if (identifier ~= print or print_to_array or call) rfalse;\
486 switch(Z__Region(obj))\
487 { 2: if (identifier == call) rtrue;\
488 3: if (identifier == print or print_to_array) rtrue;\
493 { if (obj.&identifier ~= 0) rtrue;\
496 if (obj..&identifier ~= 0) rtrue;\
497 if (identifier<72 && obj in 1) rtrue;\
502 /* OC__Cl: test whether or not given object is of the given class */
506 if (obj<1 || obj > (#largest_object-255))\
507 { if (cla ~= 3 or 4) rfalse;\
508 if (Z__Region(obj) == cla-1) rtrue;\
513 if (obj in 1) rtrue;\
515 } else if (cla == 2) {\
517 if (obj in 1) rfalse;\
519 } else if (cla == 3 or 4) {\
522 "if (cla notin 1) { RT__Err(\"apply 'ofclass' for\", cla, -1);rfalse;}\
523 @get_prop_addr obj 2 -> a;\
525 @get_prop_len a -> n;\
526 for (j=0: j<n/2: j++)\
527 { if (a-->j == cla) rtrue;\
532 { /* Copy__Primitive: routine to "deep copy" objects */
535 "o1 o2 a1 a2 n m l size identifier;\
537 { if (o2 has n) give o1 n;\
540 for (n=1:n<64:n++) if (n~=2 or 3)\
541 { a1 = o1.&n; a2 = o2.&n; size = o1.#n;\
542 if (a1~=0 && a2~=0 && size==o2.#n)\
543 { for (m=0:m<size:m++) a1->m=a2->m;\
546 "if (o1.&3 == 0 || o2.&3 == 0) return;\
547 for (n=o2.3: n-->0 ~= 0: n = n + size + 3)\
548 { identifier = n-->0;\
550 for (m=o1.3: m-->0 ~= 0: m = m + m->2 + 3)\
551 if ((identifier & $7fff == (m-->0) & $7fff) && size==m->2)\
552 for (l=3: l<size+3: l++) m->l = n->l;\
556 { /* RT__Err: for run-time errors occurring in the above: e.g.,
557 an attempt to write to a non-existent individual
561 "crime obj id size p q;\
562 print \"^[** Programming error: \";\
563 if (crime<0) jump RErr;\
564 if (crime==1) { print \"class \"; @print_obj obj;\
565 \": 'create' can have 0 to 3 parameters only **]\";}\
566 if (crime == 32) \"objectloop broken because the object \",\
567 (name) obj, \" was moved while the loop passed through it **]\";\
568 if (crime == 33) \"tried to print (char) \", obj,\
569 \", which is not a valid ZSCII character code for output **]\";\
570 if (crime == 34) \"tried to print (address) on something not the \",\
571 \"byte address of a string **]\";\
572 if (crime == 35) \"tried to print (string) on something not a \",\
574 if (crime == 36) \"tried to print (object) on something not an \",\
575 \"object or class **]\";",
576 "if (crime < 32) { print \"tried to \";\
577 if (crime >= 28) { if (crime==28 or 29) print \"read from \";\
578 else print \"write to \";\
579 if (crime==29 or 31) print \"-\"; print \"->\", obj,\
580 \" in the\"; switch(size&7){0,1:q=0; 2:print \" string\";\
581 q=1; 3:print \" table\";q=1; 4:print \" buffer\";q=WORDSIZE;} \
582 if(size&16) print\" (->)\"; if(size&8) print\" (-->)\";\
583 \" array ~\", (string) #array_names_offset-->p,\
584 \"~, which has entries \", q, \" up to \",id,\" **]\"; }\
585 if (crime >= 24 && crime <=27) { if (crime<=25) print \"read\";\
586 else print \"write\"; print \" outside memory using \";\
587 switch(crime) { 24,26:\"-> **]\"; 25,27:\"--> **]\"; } }\
588 if (crime < 4) print \"test \"; else\
589 if (crime < 12 || crime > 20) print \"find the \"; else\
590 if (crime < 14) print \"use \";\
591 if (crime==20) \"divide by zero **]\"; print \"~\";\
593 2: print \"in~ or ~notin\"; 3: print \"has~ or ~hasnt\";\
594 4: print \"parent\"; 5: print \"eldest\"; 6: print \"child\";\
595 7: print \"younger\"; 8: print \"sibling\"; 9: print \"children\";\
596 10: print \"youngest\"; 11: print \"elder\";\
597 12: print \"objectloop\"; 13: print \"}~ at end of ~objectloop\";\
598 14: \"give~ an attribute to \", (name) obj, \" **]\";\
599 15: \"remove~ \", (name) obj, \" **]\";",
600 "16,17,18: print \"move~ \", (name) obj, \" to \", (name) id;\
601 if (crime==18) { print \", which would make a loop: \",(name) obj;\
602 p=id; if (p==obj) p=obj;\
603 else do { print \" in \", (name) p; p=parent(p);} until (p==obj);\
604 \" in \", (name) p, \" **]\"; }\
605 \" **]\"; 19: \"give~ or test ~has~ or ~hasnt~ with a non-attribute"\
606 " on the object \",(name) obj,\" **]\";\
607 21: print \".&\"; 22: print \".#\"; 23: print \".\"; }\
608 \"~ of \", (name) obj, \" **]\"; }",
609 ".RErr; if (obj>=0 && obj<=(#largest_object-255)) {\
610 if (obj && obj in Class) print \"class \";\
611 if (obj) @print_obj obj;else print \"nothing\";print\" \";}\
612 print \"(object number \", obj, \") \";\
613 if (id<0) print \"is not of class \", (name) -id;",
614 "else if (size) print \"has a property \", (property) id,\
615 \", but it is longer than 2 bytes so you cannot use ~.~\";\
617 { print \" has no property \", (property) id;\
618 p = #identifiers_table;\
620 if (id<0 || id>=size)\
621 print \" (and nor has any other object)\";\
623 print \" to \", (string) crime, \" **]^\";\
626 { /* Z__Region: Determines whether a value is:
630 0 none of the above */
634 if (addr==0 or -1) rfalse;\
636 #IfV5; #iftrue (#version_number == 6) || (#version_number == 7);\
637 @log_shift addr $FFFF -> top; #Endif; #Endif;\
638 if (Unsigned__Compare(top, $001A-->0) >= 0) rfalse;\
639 if (addr>=1 && addr<=(#largest_object-255)) rtrue;\
640 #iftrue #oddeven_packing;\
641 @test addr 1 ?~NotString;\
642 if (Unsigned__Compare(addr, #strings_offset)<0) rfalse;\
645 if (Unsigned__Compare(addr, #code_offset)<0) rfalse;\
648 if (Unsigned__Compare(addr, #strings_offset)>=0) return 3;\
649 if (Unsigned__Compare(addr, #code_offset)>=0) return 2;\
652 ]", "", "", "", "", ""
654 { /* Unsigned__Compare: returns 1 if x>y, 0 if x=y, -1 if x<y */
659 if (x<0 && y>=0) return 1;\
660 if (x>=0 && y<0) return -1;\
661 u = x&$7fff; v= y&$7fff;\
664 ]", "", "", "", "", ""
666 { /* Meta__class: returns the metaclass of an object */
670 switch(Z__Region(obj))\
671 { 2: return Routine;\
673 1: if (obj in 1 || obj <= 4) return Class;\
677 ]", "", "", "", "", ""
679 { /* CP__Tab: searches a common property table for the given
680 identifier, thus imitating the get_prop_addr opcode.
681 Returns 0 if not provided, except:
682 if the identifier supplied is -1, then returns
683 the address of the first byte after the table. */
687 while ((n=0->x) ~= 0)\
688 { if (n & $80) { x++; l = (0->x) & $3f; }\
689 else { if (n & $40) l=2; else l=1; }\
691 if ((n & $3f) == id) return x;\
694 if (id<0) return x+1; rfalse; ]", "", "", "", "", ""
696 { /* Cl__Ms: the five message-receiving properties of Classes */
699 "obj id y a b c d x;\
702 if (children(obj)<=1) rfalse; x=child(obj);\
703 remove x; if (x provides create) { if (y==0) x..create();\
704 if (y==1) x..create(a); if (y==2) x..create(a,b);\
705 if (y>3) RT__Err(1,obj); if (y>=3) x..create(a,b,c);}\
708 if (~~(a ofclass obj))\
709 { RT__Err(\"recreate\", a, -obj); rfalse; }\
710 Copy__Primitive(a, child(obj));\
711 if (a provides create) { if (y==1) a..create();\
712 if (y==2) a..create(b); if (y==3) a..create(b,c);\
713 if (y>4) RT__Err(1,obj); if (y>=4) a..create(b,c,d);\
716 if (~~(a ofclass obj))\
717 { RT__Err(\"destroy\", a, -obj); rfalse; }\
718 if (a provides destroy) a..destroy();\
719 Copy__Primitive(a, child(obj));\
720 move a to obj; rfalse;\
722 return children(obj)-1;",
724 if (~~(a ofclass obj))\
725 { RT__Err(\"copy\", a, -obj); rfalse; }\
726 if (~~(b ofclass obj))\
727 { RT__Err(\"copy\", b, -obj); rfalse; }\
728 Copy__Primitive(a, b); rfalse;\
732 { /* RT__ChT: check at run-time that a proposed object move is legal
733 cause error and do nothing if not; otherwise move */
737 if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
738 return RT__Err(16,obj1,obj2);\
739 if (obj2<5 || obj2>(#largest_object-255) || obj2 in 1)\
740 return RT__Err(17,obj1,obj2);",
741 "x=obj2; while (x~=0) { if (x==obj1) return RT__Err(18,obj1,obj2); \
744 if (obj1 has infix__watching\
745 || obj2 has infix__watching || (debug_flag & 15))\
746 print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
747 #ifnot; #ifdef DEBUG;\
748 if (debug_flag & 15)\
749 print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
751 @insert_obj obj1 obj2; ]", "", "", "", ""
753 { /* RT__ChR: check at run-time that a proposed object remove is legal
754 cause error and do nothing if not; otherwise remove */
758 if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
759 return RT__Err(15,obj1);",
761 if (obj1 has infix__watching || (debug_flag & 15))\
762 print \"[Removing \", (name) obj1, \"]^\";\
763 #ifnot; #ifdef DEBUG;\
764 if (debug_flag & 15)\
765 print \"[Removing \", (name) obj1, \"]^\";\
767 @remove_obj obj1; ]", "", "", "", ""
769 { /* RT__ChG: check at run-time that a proposed attr give is legal
770 cause error and do nothing if not; otherwise give */
774 if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
775 return RT__Err(14,obj1); if (a<0 || a>=48) return RT__Err(19,obj1);\
776 if (obj1 has a) return;",
778 if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
779 print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
780 #ifnot; #ifdef DEBUG;\
781 if (a ~= workflag && debug_flag & 15)\
782 print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
784 @set_attr obj1 a; ]", "", "", "", ""
786 { /* RT__ChGt: check at run-time that a proposed attr give ~ is legal
787 cause error and do nothing if not; otherwise give */
791 if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
792 return RT__Err(14,obj1); if (a<0 || a>=48) return RT__Err(19,obj1);\
793 if (obj1 hasnt a) return;",
795 if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
796 print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
797 #ifnot; #ifdef DEBUG;\
798 if (a ~= workflag && debug_flag & 15)\
799 print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
801 @clear_attr obj1 a; ]", "", "", "", ""
803 { /* RT__ChPS: check at run-time that a proposed property set is legal
804 cause error and do nothing if not; otherwise make it */
808 if (obj<5 || obj>(#largest_object-255) || obj in 1 || obj.&prop==0 || (size=obj.#prop)>2 )\
809 return RT__Err(\"set\", obj, prop, size);\
810 @put_prop obj prop val;",
812 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,prop,val);\
813 #ifnot; #ifdef DEBUG;\
814 if (debug_flag & 15) RT__TrPS(obj,prop,val);\
816 return val; ]", "", "", "", ""
818 { /* RT__ChPR: check at run-time that a proposed property read is legal
819 cause error and return 0 if not; otherwise read it */
823 if (obj<5 || obj>(#largest_object-255) || (size=obj.#prop)>2)\
824 {RT__Err(\"read\", obj, prop, size); obj=2;}\
825 @get_prop obj prop -> val;",
826 "return val; ]", "", "", "", ""
828 { /* RT__TrPS: trace property settings */
832 print \"[Setting \",(name) obj,\".\",(property) prop,\
833 \" to \",val,\"]^\"; ]",
836 { /* RT__ChLDB: check at run-time that it's safe to load a byte
837 and return the byte */
841 a=base+offset;if (Unsigned__Compare(a,#readable_memory_offset)>=0)\
842 return RT__Err(24);",
843 "@loadb base offset -> val;return val; ]", "", "", "", ""
845 { /* RT__ChLDW: check at run-time that it's safe to load a word
846 and return the word */
850 a=base+2*offset;if (Unsigned__Compare(a,#readable_memory_offset)>=0)\
851 return RT__Err(25);",
852 "@loadw base offset -> val;return val; ]", "", "", "", ""
854 { /* RT__ChSTB: check at run-time that it's safe to store a byte
858 "base offset val a f;\
860 if (Unsigned__Compare(a,#array__start)>=0\
861 && Unsigned__Compare(a,#array__end)<0) f=1; else\
862 if (Unsigned__Compare(a,#cpv__start)>=0\
863 && Unsigned__Compare(a,#cpv__end)<0) f=1; else\
864 if (Unsigned__Compare(a,#ipv__start)>=0\
865 && Unsigned__Compare(a,#ipv__end)<0) f=1; else\
867 if (f==0) return RT__Err(26);",
868 "@storeb base offset val; ]", "", "", "", ""
870 { /* RT__ChSTW: check at run-time that it's safe to store a word
874 "base offset val a f;\
876 if (Unsigned__Compare(a,#array__start)>=0\
877 && Unsigned__Compare(a,#array__end)<0) f=1; else\
878 if (Unsigned__Compare(a,#cpv__start)>=0\
879 && Unsigned__Compare(a,#cpv__end)<0) f=1; else\
880 if (Unsigned__Compare(a,#ipv__start)>=0\
881 && Unsigned__Compare(a,#ipv__end)<0) f=1; else\
883 if (f==0) return RT__Err(27);",
884 "@storew base offset val; ]", "", "", "", ""
886 { /* RT__ChPrintC: check at run-time that it's safe to print (char)
891 if (c==0 or 9 or 11 or 13) fl=1;\
892 if (c>=32 && c<=126) fl=1; if (c>=155 && c<=251) fl=1;\
893 if (fl==0) return RT__Err(33,c);",
894 "@print_char c; ]", "", "", "", ""
896 { /* RT__ChPrintA: check at run-time that it's safe to print (address)
901 if (Unsigned__Compare(a, #readable_memory_offset)>=0)\
902 return RT__Err(34);",
903 "@print_addr a; ]", "", "", "", ""
905 { /* RT__ChPrintS: check at run-time that it's safe to print (string)
910 if (Z__Region(a)~=3) return RT__Err(35);",
911 "@print_paddr a; ]", "", "", "", ""
913 { /* RT__ChPrintO: check at run-time that it's safe to print (object)
918 if (Z__Region(a)~=1) return RT__Err(36);",
919 "@print_obj a; ]", "", "", "", ""
923 static VeneerRoutine VRs_g[VENEER_ROUTINES] =
926 /* Box__Routine: Display the given array of text as a box quote.
927 This is a very simple implementation; the library should provide
934 for (ix=0 : ix<arr-->0 : ix++) {\
935 print (string) arr-->(ix+1);\
939 ]", "", "", "", "", ""
942 /* This batch of routines is expected to be defined (rather better) by
943 the Inform library: these minimal forms here are provided to prevent
944 tiny non-library-using programs from failing to compile when certain
945 legal syntaxes (such as <<Action a b>>;) are used. */
948 "a b c d; print \"Action <\", a, \" \", b, \" \", c;\
949 if (d) print \", \", d; print \">^\";\
950 ]", "", "", "", "", ""
953 "obj; print \"the \", obj; ]", "", "", "", "", ""
956 "obj; print \"a \", obj; ]", "", "", "", "", ""
959 "obj; print \"The \", obj; ]", "", "", "", "", ""
962 "obj; print \"A \", obj; ]", "", "", "", "", ""
965 "obj q; switch(metaclass(obj))\
966 { 0: print \"nothing\";\
967 Object: q = obj-->GOBJFIELD_NAME; @streamstr q;\
968 Class: print \"class \"; q = obj-->GOBJFIELD_NAME; @streamstr q;\
969 Routine: print \"(routine at \", obj, \")\";\
970 String: print \"(string at \", obj, \")\";\
971 } ]", "", "", "", "", ""
974 "obj; print obj; ]", "", "", "", "", ""
977 /* Print__PName: Print the name of a property.
980 "prop ptab cla maxcom minind maxind str;\
981 if (prop & $FFFF0000) {\
982 cla = #classes_table-->(prop & $FFFF);\
983 print (name) cla, \"::\";\
984 @ushiftr prop 16 prop;\
986 ptab = #identifiers_table;\
988 minind = INDIV_PROP_START;\
989 maxind = minind + ptab-->3;\
991 if (prop >= 0 && prop < maxcom) {\
992 str = (ptab-->0)-->prop;\
994 else if (prop >= minind && prop < maxind) {\
995 str = (ptab-->2)-->(prop-minind);\
1000 print \"<number \", prop, \">\";\
1001 ]", "", "", "", "", ""
1004 /* The remaining routines make up the run-time half of the object
1005 orientation system, and need never be present for Inform 5 programs. */
1008 /* WV__Pr: Write a value to the property for the given object.
1014 RT__Err(\"write\", obj, id);\
1019 ]", "", "", "", "", ""
1023 /* RV__Pr: Read a value to the property for the given object.
1029 if (id > 0 && id < INDIV_PROP_START) {\
1030 return #cpv__start-->id;\
1032 RT__Err(\"read\", obj, id);\
1036 ]", "", "", "", "", ""
1039 /* CA__Pr: Call, that is, print-or-run-or-read, a property:
1040 this exactly implements obj..prop(...). Note that
1041 classes (members of Class) have 5 built-in properties
1042 inherited from Class: create, recreate, destroy,
1043 remaining and copy. Implementing these here prevents
1044 the need for a full metaclass inheritance scheme.
1047 "_vararg_count obj id zr s s2 z addr len m val;\
1050 _vararg_count = _vararg_count - 2;\
1051 zr = Z__Region(obj);\
1054 s = sender; sender = self; self = obj;\
1055 #ifdef action; sw__var=action; #endif;\
1056 @call obj _vararg_count z;\
1057 self = sender; sender = s;\
1064 @streamstr obj; rtrue;\
1066 if (id == print_to_array) {\
1067 if (_vararg_count >= 2) {\
1072 RT__Err(37); rfalse;\
1075 s = glk($0043, m+4, len-4, 1, 0);",
1080 @copy $ffffffff sp;\
1094 #ifdef DEBUG;#ifdef InformLibrary;\
1095 if (debug_flag & 1 ~= 0) {\
1097 print \"[ ~\", (name) obj, \"~.\", (property) id, \"(\";\
1098 @stkcopy _vararg_count;\
1099 for (val=0 : val < _vararg_count : val++) {\
1100 if (val) print \", \";\
1107 if (obj in Class) {\
1110 return Cl__Ms(obj, id);\
1114 return Cl__Ms(obj, id, m, val);\
1115 create, destroy, recreate:\
1116 m = _vararg_count+2;\
1119 @call Cl__Ms m val;\
1125 if (id > 0 && id < INDIV_PROP_START) {\
1126 addr = #cpv__start + 4*id;\
1136 for (m=0 : 4*m<len : m++) {\
1138 if (val == -1) rfalse;\
1139 switch (Z__Region(val)) {\
1141 s = sender; sender = self; self = obj; s2 = sw__var;\
1143 if (id==life) sw__var=reason_code; else sw__var=action;\
1145 " @stkcopy _vararg_count;\
1146 @call val _vararg_count z;\
1147 self = sender; sender = s; sw__var = s2;\
1148 if (z ~= 0) return z;\
1159 RT__Err(\"send message\", obj, id);\
1164 /* IB__Pr: ++(individual property) */
1168 x = obj.&identifier;\
1169 if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
1171 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)+1);\
1172 #ifnot; #ifdef DEBUG;\
1173 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
1176 ]", "", "", "", "", ""
1179 /* IA__Pr: (individual property)++ */
1183 x = obj.&identifier;\
1184 if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
1186 if (obj has infix__watching || (debug_flag & 15))\
1187 RT__TrPS(obj,identifier,(x-->0)+1);\
1188 #ifnot; #ifdef DEBUG;\
1189 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
1192 ]", "", "", "", "", ""
1195 /* DB__Pr: --(individual property) */
1199 x = obj.&identifier;\
1200 if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
1202 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
1203 #ifnot; #ifdef DEBUG;\
1204 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
1207 ]", "", "", "", "", ""
1210 /* DA__Pr: (individual property)-- */
1214 x = obj.&identifier;\
1215 if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
1217 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
1218 #ifnot; #ifdef DEBUG;\
1219 if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
1222 ]", "", "", "", "", ""
1225 /* RA__Pr: Read the property address of a given property value.
1226 Returns zero if it isn't provided by the object. This
1227 understands all the same concerns as RL__Pr().
1230 "obj id cla prop ix;\
1231 if (id & $FFFF0000) {\
1232 cla = #classes_table-->(id & $FFFF);\
1233 if (~~(obj ofclass cla)) return 0;\
1237 prop = CP__Tab(obj, id);\
1238 if (prop==0) return 0;\
1239 if (obj in Class && cla == 0) {\
1240 if (id < INDIV_PROP_START || id >= INDIV_PROP_START+8)\
1244 @aloadbit prop 72 ix;\
1248 ]", "", "", "", "", ""
1252 /* RL__Pr: Read the property length of a given property value.
1253 Returns zero if it isn't provided by the object. This understands
1254 inherited values (of the form class::prop) as well as simple
1255 property ids and the special metaclass methods. It also knows
1256 that private properties can only be read if (self == obj).
1259 "obj id cla prop ix;\
1260 if (id & $FFFF0000) {\
1261 cla = #classes_table-->(id & $FFFF);\
1262 if (~~(obj ofclass cla)) return 0;\
1266 prop = CP__Tab(obj, id);\
1267 if (prop==0) return 0;\
1268 if (obj in Class && cla == 0) {\
1269 if (id < INDIV_PROP_START || id >= INDIV_PROP_START+8)\
1273 @aloadbit prop 72 ix;\
1277 return WORDSIZE * ix;\
1278 ]", "", "", "", "", ""
1281 /* RA__Sc: Implement the \"superclass\" (::) operator. This
1282 returns an compound property identifier, which is a
1287 if ((cla notin Class) && (cla ~= Class or String or Routine or Object)) {\
1288 RT__Err(\"be a '::' superclass\", cla, -1);\
1291 for (j=0 : #classes_table-->j ~= 0 : j++) {\
1292 if (cla == #classes_table-->j) {\
1293 return (id * $10000 + j);\
1296 RT__Err(\"make use of\", cla, id);\
1298 ]", "", "", "", "", ""
1302 /* OP__Pr: Test whether the given object provides the given property.
1303 This winds up calling RA__Pr().
1307 zr = Z__Region(obj);\
1309 if (id == print or print_to_array) rtrue;\
1313 if (id == call) rtrue;\
1316 if (zr ~= 1) rfalse;\
1317 if (id >= INDIV_PROP_START && id < INDIV_PROP_START+8) {\
1318 if (obj in Class) rtrue;\
1323 ]", "", "", "", "", ""
1326 /* OC__Cl: Test whether the given object is of the given class.
1327 (implements the OfClass operator.)
1330 "obj cla zr jx inlist inlistlen;\
1331 zr = Z__Region(obj);\
1333 if (cla == String) rtrue;\
1337 if (cla == Routine) rtrue;\
1340 if (zr ~= 1) rfalse;\
1341 if (cla == Class) {\
1343 || obj == Class or String or Routine or Object)\
1347 if (cla == Object) {\
1349 || obj == Class or String or Routine or Object)\
1353 if (cla == String or Routine) rfalse;\
1354 if (cla notin Class) {\
1355 RT__Err(\"apply 'ofclass' for\", cla, -1);\
1359 if (inlist == 0) rfalse;\
1360 inlistlen = (obj.#2) / WORDSIZE;\
1361 for (jx=0 : jx<inlistlen : jx++) {\
1362 if (inlist-->jx == cla) rtrue;\
1365 ]", "", "", "", "", ""
1369 /* Copy__Primitive: Routine to \"deep copy\" objects.
1372 "o1 o2 p1 p2 pcount i j propid proplen val pa1 pa2;\
1373 for (i=1 : i<=NUM_ATTR_BYTES : i++) {\
1376 p2 = o2-->GOBJFIELD_PROPTAB;\
1379 for (i=0 : i<pcount : i++) {\
1380 @aloads p2 0 propid;\
1381 @aloads p2 1 proplen;\
1382 p1 = CP__Tab(o1, propid);\
1385 if (proplen == val) {\
1390 for (j=0 : j<proplen : j++)\
1396 ]", "", "", "", "", ""
1398 { /* RT__Err: for run-time errors occurring in the above: e.g.,
1399 an attempt to write to a non-existent individual
1403 "crime obj id size p q;\
1404 print \"^[** Programming error: \";\
1405 if (crime<0) jump RErr;\
1406 if (crime==1) { print \"class \"; q = obj-->GOBJFIELD_NAME; @streamstr q;\
1407 \": 'create' can have 0 to 3 parameters only **]\";}\
1408 if (crime == 40) \"tried to change printing variable \",\
1409 obj, \"; must be 0 to \", #dynam_string_table-->0-1, \" **]\";\
1410 if (crime == 32) \"objectloop broken because the object \",\
1411 (name) obj, \" was moved while the loop passed through it **]\";\
1412 if (crime == 33) \"tried to print (char) \", obj,\
1413 \", which is not a valid Glk character code for output **]\";\
1414 if (crime == 34) \"tried to print (address) on something not the \",\
1415 \"address of a dict word **]\";\
1416 if (crime == 35) \"tried to print (string) on something not a \",\
1418 if (crime == 36) \"tried to print (object) on something not an \",\
1419 \"object or class **]\";\
1420 if (crime == 37) \"tried to call Glulx print_to_array with only \",\
1421 \"one argument **]\";",
1422 "if (crime < 32) { print \"tried to \";\
1423 if (crime >= 28) { if (crime==28 or 29) print \"read from \";\
1424 else print \"write to \";\
1425 if (crime==29 or 31) print \"-\"; print \"->\", obj,\
1426 \" in the\"; switch(size&7){0,1:q=0; 2:print \" string\";\
1427 q=1; 3:print \" table\";q=1; 4:print \" buffer\";q=WORDSIZE;} \
1428 if(size&16) print\" (->)\"; if(size&8) print\" (-->)\";\
1429 \" array ~\", (string) #array_names_offset-->(p+1),\
1430 \"~, which has entries \", q, \" up to \",id,\" **]\"; }\
1431 if (crime >= 24 && crime <=27) { if (crime<=25) print \"read\";\
1432 else print \"write\"; print \" outside memory using \";\
1433 switch(crime) { 24,26:\"-> **]\"; 25,27:\"--> **]\"; } }\
1434 if (crime < 4) print \"test \"; else\
1435 if (crime < 12 || crime > 20) print \"find the \"; else\
1436 if (crime < 14) print \"use \";\
1437 if (crime==20) \"divide by zero **]\"; print \"~\";\
1439 2: print \"in~ or ~notin\"; 3: print \"has~ or ~hasnt\";\
1440 4: print \"parent\"; 5: print \"eldest\"; 6: print \"child\";\
1441 7: print \"younger\"; 8: print \"sibling\"; 9: print \"children\";\
1442 10: print \"youngest\"; 11: print \"elder\";\
1443 12: print \"objectloop\"; 13: print \"}~ at end of ~objectloop\";\
1444 14: \"give~ an attribute to \", (name) obj, \" **]\";\
1445 15: \"remove~ \", (name) obj, \" **]\";",
1446 "16,17,18: print \"move~ \", (name) obj, \" to \", (name) id;\
1447 if (crime==18) { print \", which would make a loop: \",(name) obj;\
1448 p=id; if (p==obj) p=obj;\
1449 else do { print \" in \", (name) p; p=parent(p);} until (p==obj);\
1450 \" in \", (name) p, \" **]\"; }\
1451 \" **]\"; 19: \"give~ or test ~has~ or ~hasnt~ with a non-attribute"\
1452 " on the object \",(name) obj,\" **]\";\
1453 21: print \".&\"; 22: print \".#\"; 23: print \".\"; }\
1454 \"~ of \", (name) obj, \" **]\"; }",
1455 ".RErr; if (obj==0 || obj->0>=$70 && obj->0<=$7F) {\
1456 if (obj && obj in Class) print \"class \";\
1457 if (obj) print (object) obj;else print \"nothing\";print\" \";}\
1458 print \"(object number \", obj, \") \";\
1459 if (id<0) print \"is not of class \", (name) -id;",
1461 { print \" has no property \", (property) id;\
1462 p = #identifiers_table;\
1463 size = INDIV_PROP_START + p-->3;\
1464 if (id<0 || id>=size)\
1465 print \" (and nor has any other object)\";\
1467 print \" to \", (string) crime, \" **]^\";\
1471 /* Z__Region: Determines whether a value is:
1479 if (addr<36) rfalse;\
1480 @getmemsize endmem;\
1481 @jgeu addr endmem?outrange;\
1483 if (tb >= $E0) return 3;\
1484 if (tb >= $C0) return 2;\
1485 if (tb >= $70 && tb <= $7F && addr >= (0-->2)) return 1;\
1488 ]", "", "", "", "", ""
1490 { /* Unsigned__Compare: returns 1 if x>y, 0 if x=y, -1 if x<y */
1492 "Unsigned__Compare",
1501 ]", "", "", "", "", ""
1503 { /* Meta__class: returns the metaclass of an object */
1507 switch(Z__Region(obj))\
1508 { 2: return Routine;\
1510 1: if (obj in Class\
1511 || obj == Class or String or Routine or Object)\
1516 ]", "", "", "", "", ""
1520 /* CP__Tab: Search a property table for the given identifier.
1521 The definition here is a bit different from the Z-code veneer.
1522 This just searches the property table of obj for an entry with
1523 the given identifier. It return the address of the property
1524 entry, or 0 if nothing found. (Remember that the value returned
1525 is not the address of the property *data*; it's the structure
1526 which contains the address/length/flags.)
1529 "obj id otab max res;\
1530 if (Z__Region(obj)~=1) {RT__Err(23, obj); rfalse;}\
1531 otab = obj-->GOBJFIELD_PROPTAB;\
1532 if (otab == 0) return 0;\
1535 @binarysearch id 2 otab 10 max 0 0 res;\
1537 ]", "", "", "", "", ""
1541 /* Cl__Ms: Implements the five message-receiving properties of
1545 "_vararg_count obj id a b x y;\
1548 _vararg_count = _vararg_count - 2;\
1551 if (children(obj) <= 1) rfalse;\
1554 if (x provides create) {\
1557 y = _vararg_count + 2;\
1564 if (~~(a ofclass obj)) {\
1565 RT__Err(\"recreate\", a, -obj);\
1568 if (a provides destroy)\
1570 Copy__Primitive(a, child(obj));\
1571 if (a provides create) {\
1574 y = _vararg_count + 2;\
1581 if (~~(a ofclass obj)) {\
1582 RT__Err(\"destroy\", a, -obj);\
1585 if (a provides destroy)\
1587 Copy__Primitive(a, child(obj));\
1591 return children(obj)-1;\
1595 _vararg_count = _vararg_count - 2;\
1596 if (~~(a ofclass obj)) {\
1597 RT__Err(\"copy\", a, -obj);\
1600 if (~~(b ofclass obj)) {\
1601 RT__Err(\"copy\", b, -obj);\
1604 Copy__Primitive(a, b);\
1607 ]", "", "", "", "", ""
1610 /* RT__ChT: Check at run-time that a proposed object move is legal.
1611 Cause error and do nothing if not; otherwise move
1615 if (obj1==0 || Z__Region(obj1)~=1\
1616 || (obj1 == Class or String or Routine or Object) || obj1 in Class)\
1617 return RT__Err(16, obj1, obj2);\
1618 if (obj2==0 || Z__Region(obj2)~=1\
1619 || (obj2 == Class or String or Routine or Object) || obj2 in Class)\
1620 return RT__Err(17, obj1, obj2);\
1623 if (ix==obj1) return RT__Err(18, obj1, obj2);\
1627 if (obj1 has infix__watching\
1628 || obj2 has infix__watching || (debug_flag & 15))\
1629 print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
1630 #ifnot; #ifdef DEBUG;\
1631 if (debug_flag & 15)\
1632 print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
1634 OB__Move(obj1, obj2);\
1635 ]", "", "", "", "", ""
1638 /* RT__ChR: Check at run-time that a proposed object remove is legal.
1639 Cause error and do nothing if not; otherwise remove
1643 if (obj1==0 || Z__Region(obj1)~=1\
1644 || (obj1 == Class or String or Routine or Object) || obj1 in Class)\
1645 return RT__Err(15, obj1);\
1647 if (obj1 has infix__watching || (debug_flag & 15))\
1648 print \"[Removing \", (name) obj1, \"]^\";\
1649 #ifnot; #ifdef DEBUG;\
1650 if (debug_flag & 15)\
1651 print \"[Removing \", (name) obj1, \"]^\";\
1654 ]", "", "", "", "", ""
1656 { /* RT__ChG: check at run-time that a proposed attr give is legal
1657 cause error and do nothing if not; otherwise give */
1661 if (Z__Region(obj1) ~= 1) return RT__Err(14,obj1);\
1662 if (obj1 in Class || obj1 == Class or String or Routine or Object)\
1663 return RT__Err(14,obj1);\
1664 if (a<0 || a>=NUM_ATTR_BYTES*8) return RT__Err(19,obj1);\
1665 if (obj1 has a) return;",
1667 if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
1668 print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
1669 #ifnot; #ifdef DEBUG;\
1670 if (a ~= workflag && debug_flag & 15)\
1671 print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
1673 give obj1 a; ]", "", "", "", ""
1675 { /* RT__ChGt: check at run-time that a proposed attr give ~ is legal
1676 cause error and do nothing if not; otherwise give */
1680 if (Z__Region(obj1) ~= 1) return RT__Err(14,obj1);\
1681 if (obj1 in Class || obj1 == Class or String or Routine or Object)\
1682 return RT__Err(14,obj1);\
1683 if (a<0 || a>=NUM_ATTR_BYTES*8) return RT__Err(19,obj1);\
1684 if (obj1 hasnt a) return;",
1686 if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
1687 print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
1688 #ifnot; #ifdef DEBUG;\
1689 if (a ~= workflag && debug_flag & 15)\
1690 print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
1692 give obj1 ~a; ]", "", "", "", ""
1695 /* RT__ChPS: Check at run-time that a proposed property set is legal.
1696 Cause error and do nothing if not; otherwise make it.
1700 if (obj==0 || Z__Region(obj)~=1\
1701 || (obj == Class or String or Routine or Object) || obj in Class)\
1702 return RT__Err(\"set\", obj, prop);\
1703 res = WV__Pr(obj, prop, val);\
1705 if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,prop,val);\
1706 #ifnot; #ifdef DEBUG;\
1707 if (debug_flag & 15) RT__TrPS(obj,prop,val);\
1710 ]", "", "", "", "", ""
1712 { /* RT__ChPR: check at run-time that a proposed property read is legal.
1713 cause error and return 0 if not; otherwise read it */
1716 if (obj==0 or Class or String or Routine or Object || Z_Region(obj)~=1 )\
1717 {RT__Err(\"read\", obj, prop); obj=2;}\
1718 val = RV__Pr(obj, prop);",
1719 "return val; ]", "", "", "", ""
1721 { /* RT__TrPS: trace property settings */
1725 print \"[Setting \",(name) obj,\".\",(property) prop,\
1726 \" to \",val,\"]^\"; ]",
1730 /* RT__ChLDB: Check at run-time that it's safe to load a byte
1731 and return the byte.
1734 "base offset a b val;\
1737 if (Unsigned__Compare(a, b) >= 0)\
1738 return RT__Err(24);\
1739 @aloadb base offset val;\
1741 ]", "", "", "", "", ""
1745 /* RT__ChLDW: Check at run-time that it's safe to load a word
1749 "base offset a b val;\
1750 a=base+WORDSIZE*offset;\
1752 if (Unsigned__Compare(a, b) >= 0)\
1753 return RT__Err(25);\
1754 @aload base offset val;\
1756 ]", "", "", "", "", ""
1760 /* RT__ChSTB: Check at run-time that it's safe to store a byte
1764 "base offset val a b;\
1767 if (Unsigned__Compare(a, b) >= 0) jump ChSTB_Fail;\
1769 if (Unsigned__Compare(a, b) < 0) jump ChSTB_Fail;\
1770 @astoreb base offset val;\
1773 return RT__Err(26);\
1774 ]", "", "", "", "", ""
1778 /* RT__ChSTW: Check at run-time that it's safe to store a word
1782 "base offset val a b;\
1783 a=base+WORDSIZE*offset;\
1785 if (Unsigned__Compare(a, b) >= 0) jump ChSTW_Fail;\
1787 if (Unsigned__Compare(a, b) < 0) jump ChSTW_Fail;\
1788 @astore base offset val;\
1791 return RT__Err(27);\
1792 ]", "", "", "", "", ""
1796 /* RT__ChPrintC: Check at run-time that it's safe to print (char)
1801 if (c<10 || (c>10 && c<32) || (c>126 && c<160))\
1802 return RT__Err(33,c);\
1807 ]", "", "", "", "", ""
1810 /* RT__ChPrintA: Check at run-time that it's safe to print (address)
1816 return RT__Err(34);\
1817 @getmemsize endmem;\
1818 if (Unsigned__Compare(addr, endmem) >= 0)\
1819 return RT__Err(34);\
1820 if (addr->0 ~= $60)\
1821 return RT__Err(34);\
1823 ]", "", "", "", "", ""
1826 /* Check at run-time that it's safe to print (string) and do so.
1830 if (Z__Region(str) ~= 3)\
1831 return RT__Err(35);\
1833 ]", "", "", "", "", ""
1836 /* Check at run-time that it's safe to print (object) and do so.
1840 if (Z__Region(obj) ~= 1)\
1841 return RT__Err(36);\
1842 @aload obj GOBJFIELD_NAME sp; @streamstr sp;\
1843 ]", "", "", "", "", ""
1846 /* OB__Move: Move an object within the object tree. This does no
1847 more error checking than the Z-code \"move\" opcode.
1850 "obj dest par chi sib;\
1851 par = obj-->GOBJFIELD_PARENT;\
1853 chi = par-->GOBJFIELD_CHILD;\
1855 par-->GOBJFIELD_CHILD = obj-->GOBJFIELD_SIBLING;\
1859 sib = chi-->GOBJFIELD_SIBLING;\
1864 chi-->GOBJFIELD_SIBLING = obj-->GOBJFIELD_SIBLING;\
1867 obj-->GOBJFIELD_SIBLING = dest-->GOBJFIELD_CHILD;\
1868 obj-->GOBJFIELD_PARENT = dest;\
1869 dest-->GOBJFIELD_CHILD = obj;\
1871 ]", "", "", "", "", ""
1875 /* OB__Remove: Remove an object from the tree. This does no
1876 more error checking than the Z-code \"remove\" opcode.
1880 par = obj-->GOBJFIELD_PARENT;\
1883 chi = par-->GOBJFIELD_CHILD;\
1885 par-->GOBJFIELD_CHILD = obj-->GOBJFIELD_SIBLING;\
1889 sib = chi-->GOBJFIELD_SIBLING;\
1894 chi-->GOBJFIELD_SIBLING = obj-->GOBJFIELD_SIBLING;\
1896 obj-->GOBJFIELD_SIBLING = 0;\
1897 obj-->GOBJFIELD_PARENT = 0;\
1899 ]", "", "", "", "", ""
1903 /* Print__Addr: Handle the print (address) statement. In Glulx,
1904 this behaves differently than on the Z-machine; it can *only*
1905 print dictionary words.
1909 if (addr->0 ~= $60) {\
1910 print \"(\", addr, \": not dict word)\";\
1913 for (ix=1 : ix <= DICT_WORD_SIZE : ix++) {\
1914 #ifndef DICT_IS_UNICODE;\
1919 if (ch == 0) return;\
1922 ]", "", "", "", "", ""
1926 /* Glk__Wrap: This is a wrapper for the @glk opcode. It just passes
1927 all its arguments into the Glk dispatcher, and returns the Glk
1931 "_vararg_count callid retval;\
1933 _vararg_count = _vararg_count - 1;\
1934 @glk callid _vararg_count retval;\
1936 ]", "", "", "", "", ""
1940 /* Dynam__String: Set dynamic string (printing variable) num to the
1941 given val, which can be any string or function.
1945 if (num < 0 || num >= #dynam_string_table-->0)\
1946 return RT__Err(40, num);\
1947 (#dynam_string_table)-->(num+1) = val;\
1948 ]", "", "", "", "", ""
1954 static void mark_as_needed_z(int code)
1957 if (veneer_routine_needs_compilation[code] == VR_UNUSED)
1958 { veneer_routine_needs_compilation[code] = VR_CALLED;
1959 /* Here each routine must mark every veneer routine it explicitly
1963 mark_as_needed_z(RT__TrPS_VR);
1964 mark_as_needed_z(RT__Err_VR);
1967 mark_as_needed_z(RT__Err_VR);
1970 mark_as_needed_z(Z__Region_VR);
1971 mark_as_needed_z(Cl__Ms_VR);
1972 mark_as_needed_z(RT__Err_VR);
1978 mark_as_needed_z(RT__Err_VR);
1979 mark_as_needed_z(RT__TrPS_VR);
1982 mark_as_needed_z(CP__Tab_VR);
1985 mark_as_needed_z(RT__Err_VR);
1988 mark_as_needed_z(Z__Region_VR);
1991 mark_as_needed_z(Z__Region_VR);
1992 mark_as_needed_z(RT__Err_VR);
1995 mark_as_needed_z(Unsigned__Compare_VR);
1998 mark_as_needed_z(Z__Region_VR);
2001 mark_as_needed_z(RT__Err_VR);
2002 mark_as_needed_z(Copy__Primitive_VR);
2009 mark_as_needed_z(RT__Err_VR);
2012 mark_as_needed_z(RT__Err_VR);
2013 mark_as_needed_z(RT__TrPS_VR);
2019 mark_as_needed_z(Unsigned__Compare_VR);
2020 mark_as_needed_z(RT__Err_VR);
2022 case RT__ChPrintC_VR:
2023 mark_as_needed_z(RT__Err_VR);
2025 case RT__ChPrintA_VR:
2026 mark_as_needed_z(Unsigned__Compare_VR);
2027 mark_as_needed_z(RT__Err_VR);
2029 case RT__ChPrintS_VR:
2030 case RT__ChPrintO_VR:
2031 mark_as_needed_z(RT__Err_VR);
2032 mark_as_needed_z(Z__Region_VR);
2038 static void mark_as_needed_g(int code)
2041 if (veneer_routine_needs_compilation[code] == VR_UNUSED)
2042 { veneer_routine_needs_compilation[code] = VR_CALLED;
2043 /* Here each routine must mark every veneer routine it explicitly
2047 case PrintShortName_VR:
2048 mark_as_needed_g(Metaclass_VR);
2050 case Print__Pname_VR:
2051 mark_as_needed_g(PrintShortName_VR);
2054 mark_as_needed_g(RA__Pr_VR);
2055 mark_as_needed_g(RT__TrPS_VR);
2056 mark_as_needed_g(RT__Err_VR);
2059 mark_as_needed_g(RA__Pr_VR);
2060 mark_as_needed_g(RT__Err_VR);
2063 mark_as_needed_g(RA__Pr_VR);
2064 mark_as_needed_g(RL__Pr_VR);
2065 mark_as_needed_g(PrintShortName_VR);
2066 mark_as_needed_g(Print__Pname_VR);
2067 mark_as_needed_g(Z__Region_VR);
2068 mark_as_needed_g(Cl__Ms_VR);
2069 mark_as_needed_g(Glk__Wrap_VR);
2070 mark_as_needed_g(RT__Err_VR);
2076 mark_as_needed_g(RT__Err_VR);
2077 mark_as_needed_g(RT__TrPS_VR);
2080 mark_as_needed_g(OC__Cl_VR);
2081 mark_as_needed_g(CP__Tab_VR);
2084 mark_as_needed_g(OC__Cl_VR);
2085 mark_as_needed_g(CP__Tab_VR);
2088 mark_as_needed_g(OC__Cl_VR);
2089 mark_as_needed_g(RT__Err_VR);
2092 mark_as_needed_g(RA__Pr_VR);
2093 mark_as_needed_g(Z__Region_VR);
2096 mark_as_needed_g(RA__Pr_VR);
2097 mark_as_needed_g(RL__Pr_VR);
2098 mark_as_needed_g(Z__Region_VR);
2099 mark_as_needed_g(RT__Err_VR);
2101 case Copy__Primitive_VR:
2102 mark_as_needed_g(CP__Tab_VR);
2105 mark_as_needed_g(Unsigned__Compare_VR);
2109 mark_as_needed_g(Z__Region_VR);
2112 mark_as_needed_g(OC__Cl_VR);
2113 mark_as_needed_g(OP__Pr_VR);
2114 mark_as_needed_g(RT__Err_VR);
2115 mark_as_needed_g(Copy__Primitive_VR);
2116 mark_as_needed_g(OB__Remove_VR);
2117 mark_as_needed_g(OB__Move_VR);
2121 mark_as_needed_g(RT__Err_VR);
2124 mark_as_needed_g(RT__Err_VR);
2125 mark_as_needed_g(Z__Region_VR);
2126 mark_as_needed_g(OB__Remove_VR);
2129 mark_as_needed_g(RT__Err_VR);
2130 mark_as_needed_g(Z__Region_VR);
2131 mark_as_needed_g(OB__Move_VR);
2134 mark_as_needed_g(RT__Err_VR);
2135 mark_as_needed_g(RT__TrPS_VR);
2136 mark_as_needed_g(WV__Pr_VR);
2139 mark_as_needed_g(RT__Err_VR);
2140 mark_as_needed_g(RV__Pr_VR); return;
2145 mark_as_needed_g(Unsigned__Compare_VR);
2146 mark_as_needed_g(RT__Err_VR);
2148 case RT__ChPrintC_VR:
2149 mark_as_needed_g(RT__Err_VR);
2151 case RT__ChPrintA_VR:
2152 mark_as_needed_g(Unsigned__Compare_VR);
2153 mark_as_needed_g(RT__Err_VR);
2154 mark_as_needed_g(Print__Addr_VR);
2156 case RT__ChPrintS_VR:
2157 case RT__ChPrintO_VR:
2158 mark_as_needed_g(RT__Err_VR);
2159 mark_as_needed_g(Z__Region_VR);
2161 case Print__Addr_VR:
2162 mark_as_needed_g(RT__Err_VR);
2164 case Dynam__String_VR:
2165 mark_as_needed_g(RT__Err_VR);
2171 extern assembly_operand veneer_routine(int code)
2172 { assembly_operand AO;
2174 INITAOTV(&AO, LONG_CONSTANT_OT, code);
2175 AO.marker = VROUTINE_MV;
2176 mark_as_needed_z(code);
2179 INITAOTV(&AO, CONSTANT_OT, code);
2180 AO.marker = VROUTINE_MV;
2181 mark_as_needed_g(code);
2186 static void compile_symbol_table_routine(void)
2187 { int32 j, nl, arrays_l, routines_l, constants_l;
2188 assembly_operand AO, AO2, AO3;
2190 /* Assign local var names for the benefit of the debugging information
2192 local_variable_texts[0] = "dummy1";
2193 local_variable_texts[1] = "dummy2";
2195 veneer_mode = TRUE; j = symbol_index("Symb__Tab", -1);
2197 assemble_routine_header(2, FALSE, "Symb__Tab", FALSE, j),
2199 sflags[j] |= SYSTEM_SFLAG + USED_SFLAG;
2200 if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG;
2204 if (define_INFIX_switch == FALSE)
2205 { assemblez_0(rfalse_zc);
2206 variable_usage[1] = TRUE;
2207 variable_usage[2] = TRUE;
2208 assemble_routine_end(FALSE, null_debug_locations);
2209 veneer_mode = FALSE;
2213 INITAOTV(&AO, VARIABLE_OT, 1);
2214 INITAOT(&AO2, SHORT_CONSTANT_OT);
2215 INITAOT(&AO3, LONG_CONSTANT_OT);
2217 arrays_l = next_label++;
2218 routines_l = next_label++;
2219 constants_l = next_label++;
2221 sequence_point_follows = FALSE;
2223 assemblez_2_branch(je_zc, AO, AO2, arrays_l, TRUE);
2224 sequence_point_follows = FALSE;
2226 assemblez_2_branch(je_zc, AO, AO2, routines_l, TRUE);
2227 sequence_point_follows = FALSE;
2229 assemblez_2_branch(je_zc, AO, AO2, constants_l, TRUE);
2230 sequence_point_follows = FALSE;
2231 assemblez_0(rtrue_zc);
2233 assemble_label_no(arrays_l);
2235 for (j=0; j<no_arrays; j++)
2237 if (AO2.value<256) AO2.type = SHORT_CONSTANT_OT;
2238 else AO2.type = LONG_CONSTANT_OT;
2240 sequence_point_follows = FALSE;
2241 assemblez_2_branch(je_zc, AO, AO2, nl, FALSE);
2242 AO3.value = array_sizes[j];
2244 assemblez_store(temp_var2, AO3);
2245 AO3.value = array_types[j];
2246 if (sflags[array_symbols[j]] & (INSF_SFLAG+SYSTEM_SFLAG))
2247 AO3.value = AO3.value + 16;
2249 assemblez_store(temp_var3, AO3);
2250 AO3.value = svals[array_symbols[j]];
2251 AO3.marker = (!array_locs[j] ? ARRAY_MV : STATIC_ARRAY_MV);
2252 assemblez_1(ret_zc, AO3);
2253 assemble_label_no(nl);
2256 sequence_point_follows = FALSE;
2257 assemblez_0(rtrue_zc);
2258 assemble_label_no(routines_l);
2259 for (j=0; j<no_named_routines; j++)
2261 if (AO2.value<256) AO2.type = SHORT_CONSTANT_OT;
2262 else AO2.type = LONG_CONSTANT_OT;
2264 sequence_point_follows = FALSE;
2265 assemblez_2_branch(je_zc, AO, AO2, nl, FALSE);
2267 if (sflags[named_routine_symbols[j]]
2268 & (INSF_SFLAG+SYSTEM_SFLAG)) AO3.value = 16;
2270 assemblez_store(temp_var3, AO3);
2271 AO3.value = svals[named_routine_symbols[j]];
2272 AO3.marker = IROUTINE_MV;
2273 assemblez_1(ret_zc, AO3);
2274 assemble_label_no(nl);
2276 sequence_point_follows = FALSE;
2277 assemblez_0(rtrue_zc);
2279 assemble_label_no(constants_l);
2280 for (j=0, no_named_constants=0; j<no_symbols; j++)
2281 { if (((stypes[j] == OBJECT_T) || (stypes[j] == CLASS_T)
2282 || (stypes[j] == CONSTANT_T))
2283 && ((sflags[j] & (UNKNOWN_SFLAG+ACTION_SFLAG))==0))
2284 { AO2.value = no_named_constants++;
2285 if (AO2.value<256) AO2.type = SHORT_CONSTANT_OT;
2286 else AO2.type = LONG_CONSTANT_OT;
2288 sequence_point_follows = FALSE;
2289 assemblez_2_branch(je_zc, AO, AO2, nl, FALSE);
2291 if (stypes[j] == OBJECT_T) AO3.value = 2;
2292 if (stypes[j] == CLASS_T) AO3.value = 1;
2293 if (sflags[j] & (INSF_SFLAG+SYSTEM_SFLAG))
2294 AO3.value = AO3.value + 16;
2296 assemblez_store(temp_var3, AO3);
2298 AO3.marker = SYMBOL_MV;
2299 assemblez_1(ret_zc, AO3);
2300 assemble_label_no(nl);
2303 no_named_constants = 0; AO3.marker = 0;
2305 sequence_point_follows = FALSE;
2306 assemblez_0(rfalse_zc);
2307 variable_usage[1] = TRUE;
2308 variable_usage[2] = TRUE;
2309 assemble_routine_end(FALSE, null_debug_locations);
2310 veneer_mode = FALSE;
2314 if (define_INFIX_switch == FALSE)
2315 { assembleg_1(return_gc, zero_operand);
2316 variable_usage[1] = TRUE;
2317 variable_usage[2] = TRUE;
2318 assemble_routine_end(FALSE, null_debug_locations);
2319 veneer_mode = FALSE;
2323 error("*** Infix symbol-table routine is not yet implemented. ***");
2327 extern void compile_veneer(void)
2328 { int i, j, try_veneer_again;
2331 if (module_switch) return;
2333 VRs = (!glulx_mode) ? VRs_z : VRs_g;
2335 /* Called at the end of the pass to insert as much of the veneer as is
2336 needed and not elsewhere compiled. */
2338 veneer_symbols_base = no_symbols;
2340 /* for (i=0; i<VENEER_ROUTINES; i++)
2341 printf("%s %d %d %d %d %d %d\n", VRs[i].name,
2342 strlen(VRs[i].source1), strlen(VRs[i].source2),
2343 strlen(VRs[i].source3), strlen(VRs[i].source4),
2344 strlen(VRs[i].source5), strlen(VRs[i].source6)); */
2346 try_veneer_again = TRUE;
2347 while (try_veneer_again)
2348 { try_veneer_again = FALSE;
2349 for (i=0; i<VENEER_ROUTINES; i++)
2350 { if (veneer_routine_needs_compilation[i] == VR_CALLED)
2351 { j = symbol_index(VRs[i].name, -1);
2352 if (sflags[j] & UNKNOWN_SFLAG)
2353 { veneer_mode = TRUE;
2354 strcpy(veneer_source_area, VRs[i].source1);
2355 strcat(veneer_source_area, VRs[i].source2);
2356 strcat(veneer_source_area, VRs[i].source3);
2357 strcat(veneer_source_area, VRs[i].source4);
2358 strcat(veneer_source_area, VRs[i].source5);
2359 strcat(veneer_source_area, VRs[i].source6);
2361 parse_routine(veneer_source_area, FALSE,
2362 VRs[i].name, TRUE, j),
2364 veneer_mode = FALSE;
2365 if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG;
2368 { if (stypes[j] != ROUTINE_T)
2369 error_named("The following name is reserved by Inform for its \
2370 own use as a routine name; you can use it as a routine name yourself (to \
2371 override the standard definition) but cannot use it for anything else:",
2374 sflags[j] |= USED_SFLAG;
2376 veneer_routine_address[i] = svals[j];
2377 veneer_routine_needs_compilation[i] = VR_COMPILED;
2378 try_veneer_again = TRUE;
2383 compile_symbol_table_routine();
2386 /* ========================================================================= */
2387 /* Data structure management routines */
2388 /* ------------------------------------------------------------------------- */
2390 extern void init_veneer_vars(void)
2394 extern void veneer_begin_pass(void)
2396 veneer_mode = FALSE;
2397 for (i=0; i<VENEER_ROUTINES; i++)
2398 { veneer_routine_needs_compilation[i] = VR_UNUSED;
2399 veneer_routine_address[i] = 0;
2403 extern void veneer_allocate_arrays(void)
2404 { veneer_source_area = my_malloc(16384, "veneer source code area");
2407 extern void veneer_free_arrays(void)
2408 { my_free(&veneer_source_area, "veneer source code area");
2411 /* ========================================================================= */