/* ------------------------------------------------------------------------- */ /* "veneer" : Compiling the run-time "veneer" of any routines invoked */ /* by the compiler (e.g. DefArt) which the program doesn't */ /* provide */ /* */ /* Part of Inform 6.30 */ /* copyright (c) Graham Nelson 1993 - 2004 */ /* */ /* ------------------------------------------------------------------------- */ #include "header.h" int veneer_mode; /* Is the code currently being compiled from the veneer? */ extern void compile_initial_routine(void) { /* The first routine present in memory in any Inform game, beginning at the code area start position, always has 0 local variables (since the interpreter begins execution with an empty stack frame): and it must "quit" rather than "return". In order not to impose these restrictions on "Main", we compile a trivial routine consisting of a call to "Main" followed by "quit". */ int32 j; assembly_operand AO; dbgl null_dbgl; null_dbgl.b1 = 0; null_dbgl.b2 = 0; null_dbgl.b3 = 0; null_dbgl.cc = 0; j = symbol_index("Main__", -1); assign_symbol(j, assemble_routine_header(0, FALSE, "Main__", &null_dbgl, FALSE, j), ROUTINE_T); sflags[j] |= SYSTEM_SFLAG + USED_SFLAG; if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG; if (!glulx_mode) { AO.value = 0; AO.type = LONG_CONSTANT_OT; AO.marker = MAIN_MV; sequence_point_follows = FALSE; if (version_number > 3) assemblez_1_to(call_vs_zc, AO, temp_var1); else assemblez_1_to(call_zc, AO, temp_var1); assemblez_0(quit_zc); } else { AO.value = 0; AO.type = CONSTANT_OT; AO.marker = MAIN_MV; sequence_point_follows = FALSE; assembleg_3(call_gc, AO, zero_operand, zero_operand); assembleg_1(return_gc, zero_operand); } assemble_routine_end(FALSE, &null_dbgl); } /* ------------------------------------------------------------------------- */ /* The rest of the veneer is applied at the end of the pass, as required. */ /* ------------------------------------------------------------------------- */ static int veneer_routine_needs_compilation[VENEER_ROUTINES]; int32 veneer_routine_address[VENEER_ROUTINES]; static int veneer_symbols_base; #define VR_UNUSED 0 #define VR_CALLED 1 #define VR_COMPILED 2 typedef struct VeneerRoutine_s { char *name; char *source1; char *source2; char *source3; char *source4; char *source5; char *source6; } VeneerRoutine; static char *veneer_source_area; static VeneerRoutine VRs_z[VENEER_ROUTINES] = { /* Box__Routine: the only veneer routine used in the implementation of an actual statement ("box", of course), written in a hybrid of Inform and assembly language. Note the transcription of the box text to the transcript output stream (-1, or $ffff). */ { "Box__Routine", "maxw table n w w2 line lc t;\ n = table --> 0;\ @add n 6 -> sp;\ @split_window sp;\ @set_window 1;\ w = 0 -> 33;\ if (w == 0) w=80;\ w2 = (w - maxw)/2;\ style reverse;\ @sub w2 2 -> w;\ line = 5;\ lc = 1;\ @set_cursor 4 w;\ spaces maxw + 4;", "do\ { @set_cursor line w;\ spaces maxw + 4;\ @set_cursor line w2;\ t = table --> lc;\ if (t~=0) print (string) t;\ line++; lc++;\ } until (lc > n);\ @set_cursor line w;\ spaces maxw + 4;\ @buffer_mode 1;\ style roman;\ @set_window 0;\ @split_window 1;\ @output_stream $ffff;\ print \"[ \";\ lc = 1;", "do\ { w = table --> lc;\ if (w ~= 0) print (string) w;\ lc++;\ if (lc > n)\ { print \"]^^\";\ break;\ }\ print \"^ \";\ } until (false);\ @output_stream 1;\ ]", "", "", "" }, /* This batch of routines is expected to be defined (rather better) by the Inform library: these minimal forms here are provided to prevent tiny non-library-using programs from failing to compile when certain legal syntaxes (such as <>;) are used. */ { "R_Process", "a b c; print \"Action <\", a, \" \", b, \" \", c, \">^\";\ ]", "", "", "", "", "" }, { "DefArt", "obj; print \"the \", obj; ]", "", "", "", "", "" }, { "InDefArt", "obj; print \"a \", obj; ]", "", "", "", "", "" }, { "CDefArt", "obj; print \"The \", obj; ]", "", "", "", "", "" }, { "CInDefArt", "obj; print \"A \", obj; ]", "", "", "", "", "" }, { "PrintShortName", "obj; switch(metaclass(obj))\ { 0: print \"nothing\";\ Object: @print_obj obj;\ Class: print \"class \"; @print_obj obj;\ Routine: print \"(routine at \", obj, \")\";\ String: print \"(string at \", obj, \")\";\ } ]", "", "", "", "", "" }, { "EnglishNumber", "obj; print obj; ]", "", "", "", "", "" }, { "Print__PName", "prop p size cla i;\ if (prop & $c000)\ { cla = #classes_table-->(prop & $ff);\ print (name) cla, \"::\";\ if ((prop & $8000) == 0) prop = (prop & $3f00)/$100;\ else\ { prop = (prop & $7f00)/$100;\ i = cla.3;\ while ((i-->0 ~= 0) && (prop>0))\ { i = i + i->2 + 3;\ prop--;\ }\ prop = (i-->0) & $7fff;\ }\ }", "p = #identifiers_table;\ size = p-->0;\ if (prop<=0 || prop>=size || p-->prop==0)\ print \"\";\ else print (string) p-->prop;\ ]", "", "", "", "" }, /* The remaining routines make up the run-time half of the object orientation system, and need never be present for Inform 5 programs. */ { /* WV__Pr: write a value to the property for the given object having the given identifier */ "WV__Pr", "obj identifier value x;\ x = obj..&identifier;\ if (x==0) { RT__Err(\"write to\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,value);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,value);\ #endif; #endif;\ x-->0 = value;\ ]", "", "", "", "", "" }, { /* RV__Pr: read a value from the property for the given object having the given identifier */ "RV__Pr", "obj identifier x;\ x = obj..&identifier;\ if (x==0)\ { if (identifier >= 1 && identifier < 64 && obj.#identifier <= 2)\ return obj.identifier;\ RT__Err(\"read\", obj, identifier); return; }\ if (obj.#identifier > 2) RT__Err(\"read\", obj, identifier, 2);\ return x-->0;\ ]", "", "", "", "", "" }, { /* CA__Pr: call, that is, print-or-run-or-read, a property: this exactly implements obj..prop(...). Note that classes (members of Class) have 5 built-in properties inherited from Class: create, recreate, destroy, remaining and copy. Implementing these here prevents the need for a full metaclass inheritance scheme. */ "CA__Pr", "obj id a b c d e f x y z s s2 n m;\ if (obj < 1 || obj > #largest_object-255)\ { switch(Z__Region(obj))\ { 2: if (id == call)\ { s = sender; sender = self; self = obj;\ #ifdef action;sw__var=action;#endif;\ x = indirect(obj, a, b, c, d, e, f);\ self = sender; sender = s; return x; }\ jump Call__Error;", "3: if (id == print) { @print_paddr obj; rtrue; }\ if (id == print_to_array)\ { @output_stream 3 a; @print_paddr obj; @output_stream -3;\ return a-->0; }\ jump Call__Error;\ }\ jump Call__Error;\ }\ @check_arg_count 3 ?~A__x;y++;@check_arg_count 4 ?~A__x;y++;\ @check_arg_count 5 ?~A__x;y++;@check_arg_count 6 ?~A__x;y++;\ @check_arg_count 7 ?~A__x;y++;@check_arg_count 8 ?~A__x;y++;.A__x;", "#ifdef INFIX;if (obj has infix__watching) n=1;#endif;\ #ifdef DEBUG;if (debug_flag & 1 ~= 0) n=1;#endif;\ if (n==1) {\ #ifdef DEBUG;n=debug_flag & 1; debug_flag=debug_flag-n;#endif;\ print \"[ ~\", (name) obj, \"~.\", (property) id, \"(\";\ switch(y) { 1: print a; 2: print a,\",\",b; 3: print a,\",\",b,\",\",c;\ 4: print a,\",\",b,\",\",c,\",\",d;\ 5: print a,\",\",b,\",\",c,\",\",d,\",\",e;\ 6: print a,\",\",b,\",\",c,\",\",d,\",\",e,\",\",f; }\ print \") ]^\";\ #ifdef DEBUG;debug_flag = debug_flag + n;#endif;\ }", "if (id > 0 && id < 64)\ { x = obj.&id; if (x==0) { x=$000a-->0 + 2*(id-1); n=2; }\ else n = obj.#id; }\ else\ { if (id>=64 && id<69 && obj in Class)\ return Cl__Ms(obj,id,y,a,b,c,d);\ x = obj..&id;\ if (x == 0) { .Call__Error;\ RT__Err(\"send message\", obj, id); return; }\ n = 0->(x-1);\ if (id&$C000==$4000)\ switch (n&$C0) { 0: n=1; $40: n=2; $80: n=n&$3F; }\ }", "for (:2*mm==$ffff) rfalse;\ switch(Z__Region(x-->m))\ { 2: s = sender; sender = self; self = obj; s2 = sw__var;\ #ifdef LibSerial;\ if (id==life) sw__var=reason_code; else sw__var=action;\ #endif;\ switch(y) { 0: z = indirect(x-->m); 1: z = indirect(x-->m, a);\ 2: z = indirect(x-->m, a, b); 3: z = indirect(x-->m, a, b, c);", "4: z = indirect(x-->m, a, b, c, d); 5:z = indirect(x-->m, a, b, c, d, e);\ 6: z = indirect(x-->m, a, b, c, d, e, f); }\ self = sender; sender = s; sw__var = s2;\ if (z ~= 0) return z;\ 3: print_ret (string) x-->m;\ default: return x-->m;\ }\ }\ rfalse;\ ]" }, { /* IB__Pr: ++(individual property) */ "IB__Pr", "obj identifier x;\ x = obj..&identifier;\ if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)+1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\ #endif; #endif;\ return ++(x-->0);\ ]", "", "", "", "", "" }, { /* IA__Pr: (individual property)++ */ "IA__Pr", "obj identifier x;\ x = obj..&identifier;\ if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15))\ RT__TrPS(obj,identifier,(x-->0)+1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\ #endif; #endif;\ return (x-->0)++;\ ]", "", "", "", "", "" }, { /* DB__Pr: --(individual property) */ "DB__Pr", "obj identifier x;\ x = obj..&identifier;\ if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\ #endif; #endif;\ return --(x-->0);\ ]", "", "", "", "", "" }, { /* DA__Pr: (individual property)-- */ "DA__Pr", "obj identifier x;\ x = obj..&identifier;\ if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\ #endif; #endif;\ return (x-->0)--;\ ]", "", "", "", "", "" }, { /* RA__Pr: read the address of a property value for a given object, returning 0 if it doesn't provide this individual property */ "RA__Pr", "obj identifier i otherid cla;\ if (obj==0) rfalse;\ if (identifier<64 && identifier>0) return obj.&identifier;\ if (identifier & $8000 ~= 0)\ { cla = #classes_table-->(identifier & $ff);\ if (cla.&3 == 0) rfalse;\ if (~~(obj ofclass cla)) rfalse;\ identifier = (identifier & $7f00) / $100;\ i = cla.3;\ while (identifier>0)\ { identifier--;\ i = i + i->2 + 3;\ }\ return i+3;\ }", "if (identifier & $4000 ~= 0)\ { cla = #classes_table-->(identifier & $ff);\ identifier = (identifier & $3f00) / $100;\ if (~~(obj ofclass cla)) rfalse; i=0-->5;\ if (cla == 2) return i+2*identifier-2;\ i = 0-->((i+124+cla*14)/2);\ i = CP__Tab(i + 2*(0->i) + 1, -1)+6;\ return CP__Tab(i, identifier);\ }\ if (obj.&3 == 0) rfalse;\ if (obj in 1)\ { if (identifier<64 || identifier>=72) rfalse;\ }", "if (self == obj)\ otherid = identifier | $8000;\ i = obj.3;\ while (i-->0 ~= 0)\ { if (i-->0 == identifier or otherid)\ return i+3;\ i = i + i->2 + 3;\ }\ rfalse;\ ]", "", "", "" }, { /* RL__Pr: read the property length of an individual property value, returning 0 if it isn't provided by the given object */ "RL__Pr", "obj identifier x;\ if (identifier<64 && identifier>0) return obj.#identifier;\ x = obj..&identifier;\ if (x==0) rfalse;\ if (identifier&$C000==$4000)\ switch (((x-1)->0)&$C0)\ { 0: return 1; $40: return 2; $80: return ((x-1)->0)&$3F; }\ return (x-1)->0;\ ]", "", "", "", "", "" }, { /* RA__Sc: implement the "superclass" (::) operator, returning an identifier */ "RA__Sc", "cla identifier otherid i j k;\ if (cla notin 1 && cla > 4)\ { RT__Err(\"be a '::' superclass\", cla, -1); rfalse; }\ if (self ofclass cla) otherid = identifier | $8000;\ for (j=0: #classes_table-->j ~= 0: j++)\ { if (cla==#classes_table-->j)\ { if (identifier < 64) return $4000 + identifier*$100 + j;\ if (cla.&3 == 0) break;\ i = cla.3;", "while (i-->0 ~= 0)\ { if (i-->0 == identifier or otherid)\ return $8000 + k*$100 + j;\ i = i + i->2 + 3;\ k++;\ }\ break;\ }\ }\ RT__Err(\"make use of\", cla, identifier);\ rfalse;\ ]", "", "", "", "" }, { /* OP__Pr: test whether or not given object provides individual property with the given identifier code */ "OP__Pr", "obj identifier;\ if (obj<1 || obj > (#largest_object-255))\ { if (identifier ~= print or print_to_array or call) rfalse;\ switch(Z__Region(obj))\ { 2: if (identifier == call) rtrue;\ 3: if (identifier == print or print_to_array) rtrue;\ }\ rfalse;\ }", "if (identifier<64)\ { if (obj.&identifier ~= 0) rtrue;\ rfalse;\ }\ if (obj..&identifier ~= 0) rtrue;\ if (identifier<72 && obj in 1) rtrue;\ rfalse;\ ]", "", "", "", "" }, { /* OC__Cl: test whether or not given object is of the given class */ "OC__Cl", "obj cla j a n;\ if (obj<1 || obj > (#largest_object-255))\ { if (cla ~= 3 or 4) rfalse;\ if (Z__Region(obj) == cla-1) rtrue;\ rfalse;\ }\ if (cla == 1) {\ if (obj<=4) rtrue;\ if (obj in 1) rtrue;\ rfalse;\ } else if (cla == 2) {\ if (obj<=4) rfalse;\ if (obj in 1) rfalse;\ rtrue;\ } else if (cla == 3 or 4) {\ rfalse;\ }", "if (cla notin 1) { RT__Err(\"apply 'ofclass' for\", cla, -1);rfalse;}\ @get_prop_addr obj 2 -> a;\ if (a==0) rfalse;\ @get_prop_len a -> n;\ for (j=0: jj == cla) rtrue;\ }\ rfalse;\ ]", "", "", "", "" }, { /* Copy__Primitive: routine to "deep copy" objects */ "Copy__Primitive", "o1 o2 a1 a2 n m l size identifier;\ for (n=0:n<48:n++)\ { if (o2 has n) give o1 n;\ else give o1 ~n;\ }\ for (n=1:n<64:n++) if (n~=2 or 3)\ { a1 = o1.&n; a2 = o2.&n; size = o1.#n;\ if (a1~=0 && a2~=0 && size==o2.#n)\ { for (m=0:mm=a2->m;\ }\ }", "if (o1.&3 == 0 || o2.&3 == 0) return;\ for (n=o2.3: n-->0 ~= 0: n = n + size + 3)\ { identifier = n-->0;\ size = n->2;\ for (m=o1.3: m-->0 ~= 0: m = m + m->2 + 3)\ if ((identifier & $7fff == (m-->0) & $7fff) && size==m->2)\ for (l=3: ll = n->l;\ }\ ]", "", "", "", "" }, { /* RT__Err: for run-time errors occurring in the above: e.g., an attempt to write to a non-existent individual property */ "RT__Err", "crime obj id size p q;\ print \"^[** Programming error: \";\ if (crime<0) jump RErr;\ if (crime==1) { print \"class \"; @print_obj obj;\ \": 'create' can have 0 to 3 parameters only **]\";}\ if (crime == 32) \"objectloop broken because the object \",\ (name) obj, \" was moved while the loop passed through it **]\";\ if (crime == 33) \"tried to print (char) \", obj,\ \", which is not a valid ZSCII character code for output **]\";\ if (crime == 34) \"tried to print (address) on something not the \",\ \"byte address of a string **]\";\ if (crime == 35) \"tried to print (string) on something not a \",\ \"string **]\";\ if (crime == 36) \"tried to print (object) on something not an \",\ \"object or class **]\";", "if (crime < 32) { print \"tried to \";\ if (crime >= 28) { if (crime==28 or 29) print \"read from \";\ else print \"write to \";\ if (crime==29 or 31) print \"-\"; print \"->\", obj,\ \" in the\"; switch(size&7){0,1:q=0; 2:print \" string\";\ q=1; 3:print \" table\";q=1; 4:print \" buffer\";q=WORDSIZE;} \ if(size&16) print\" (->)\"; if(size&8) print\" (-->)\";\ \" array ~\", (string) #array_names_offset-->p,\ \"~, which has entries \", q, \" up to \",id,\" **]\"; }\ if (crime >= 24 && crime <=27) { if (crime<=25) print \"read\";\ else print \"write\"; print \" outside memory using \";\ switch(crime) { 24,26:\"-> **]\"; 25,27:\"--> **]\"; } }\ if (crime < 4) print \"test \"; else\ if (crime < 12 || crime > 20) print \"find the \"; else\ if (crime < 14) print \"use \";\ if (crime==20) \"divide by zero **]\"; print \"~\";\ switch(crime) {\ 2: print \"in~ or ~notin\"; 3: print \"has~ or ~hasnt\";\ 4: print \"parent\"; 5: print \"eldest\"; 6: print \"child\";\ 7: print \"younger\"; 8: print \"sibling\"; 9: print \"children\";\ 10: print \"youngest\"; 11: print \"elder\";\ 12: print \"objectloop\"; 13: print \"}~ at end of ~objectloop\";\ 14: \"give~ an attribute to \", (name) obj, \" **]\";\ 15: \"remove~ \", (name) obj, \" **]\";", "16,17,18: print \"move~ \", (name) obj, \" to \", (name) id;\ if (crime==18) { print \", which would make a loop: \",(name) obj;\ p=id; if (p==obj) p=obj;\ else do { print \" in \", (name) p; p=parent(p);} until (p==obj);\ \" in \", (name) p, \" **]\"; }\ \" **]\"; 19: \"give~ or test ~has~ or ~hasnt~ with a non-attribute"\ " on the object \",(name) obj,\" **]\";\ 21: print \".&\"; 22: print \".#\"; 23: print \".\"; }\ \"~ of \", (name) obj, \" **]\"; }", ".RErr; if (obj>=0 && obj<=(#largest_object-255)) {\ if (obj && obj in Class) print \"class \";\ if (obj) @print_obj obj;else print \"nothing\";print\" \";}\ print \"(object number \", obj, \") \";\ if (id<0) print \"is not of class \", (name) -id;", "else if (size) print \"has a property \", (property) id,\ \", but it is longer than 2 bytes so you cannot use ~.~\";\ else\ { print \" has no property \", (property) id;\ p = #identifiers_table;\ size = p-->0;\ if (id<0 || id>=size)\ print \" (and nor has any other object)\";\ }\ print \" to \", (string) crime, \" **]^\";\ ]", "" }, { /* Z__Region: Determines whether a value is: 1 an object number 2 a code address 3 a string address 0 none of the above */ "Z__Region", "addr top;\ if (addr==0 or -1) rfalse;\ top = addr;\ #IfV5; #iftrue (#version_number == 6) || (#version_number == 7);\ @log_shift addr $FFFF -> top; #Endif; #Endif;\ if (Unsigned__Compare(top, $001A-->0) >= 0) rfalse;\ if (addr>=1 && addr<=(#largest_object-255)) rtrue;\ #iftrue #oddeven_packing;\ @test addr 1 ?~NotString;\ if (Unsigned__Compare(addr, #strings_offset)<0) rfalse;\ return 3;\ .NotString;\ if (Unsigned__Compare(addr, #code_offset)<0) rfalse;\ return 2;\ #ifnot;\ if (Unsigned__Compare(addr, #strings_offset)>=0) return 3;\ if (Unsigned__Compare(addr, #code_offset)>=0) return 2;\ rfalse;\ #endif;\ ]", "", "", "", "", "" }, { /* Unsigned__Compare: returns 1 if x>y, 0 if x=y, -1 if x=0) return 1;\ if (x>=0 && y<0) return -1;\ u = x&$7fff; v= y&$7fff;\ if (u>v) return 1;\ return -1;\ ]", "", "", "", "", "" }, { /* Meta__class: returns the metaclass of an object */ "Meta__class", "obj;\ switch(Z__Region(obj))\ { 2: return Routine;\ 3: return String;\ 1: if (obj in 1 || obj <= 4) return Class;\ return Object;\ }\ rfalse;\ ]", "", "", "", "", "" }, { /* CP__Tab: searches a common property table for the given identifier, thus imitating the get_prop_addr opcode. Returns 0 if not provided, except: if the identifier supplied is -1, then returns the address of the first byte after the table. */ "CP__Tab", "x id n l;\ while ((n=0->x) ~= 0)\ { if (n & $80) { x++; l = (0->x) & $3f; }\ else { if (n & $40) l=2; else l=1; }\ x++;\ if ((n & $3f) == id) return x;\ x = x + l;\ }\ if (id<0) return x+1; rfalse; ]", "", "", "", "", "" }, { /* Cl__Ms: the five message-receiving properties of Classes */ "Cl__Ms", "obj id y a b c d x;\ switch(id)\ { create:\ if (children(obj)<=1) rfalse; x=child(obj);\ remove x; if (x provides create) { if (y==0) x..create();\ if (y==1) x..create(a); if (y==2) x..create(a,b);\ if (y>3) RT__Err(1,obj); if (y>=3) x..create(a,b,c);}\ return x;\ recreate:\ if (~~(a ofclass obj))\ { RT__Err(\"recreate\", a, -obj); rfalse; }\ Copy__Primitive(a, child(obj));\ if (a provides create) { if (y==1) a..create();\ if (y==2) a..create(b); if (y==3) a..create(b,c);\ if (y>4) RT__Err(1,obj); if (y>=4) a..create(b,c,d);\ } rfalse;", "destroy:\ if (~~(a ofclass obj))\ { RT__Err(\"destroy\", a, -obj); rfalse; }\ if (a provides destroy) a..destroy();\ Copy__Primitive(a, child(obj));\ move a to obj; rfalse;\ remaining:\ return children(obj)-1;", "copy:\ if (~~(a ofclass obj))\ { RT__Err(\"copy\", a, -obj); rfalse; }\ if (~~(b ofclass obj))\ { RT__Err(\"copy\", b, -obj); rfalse; }\ Copy__Primitive(a, b); rfalse;\ }\ ]", "", "", "" }, { /* RT__ChT: check at run-time that a proposed object move is legal cause error and do nothing if not; otherwise move */ "RT__ChT", "obj1 obj2 x;\ if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\ return RT__Err(16,obj1,obj2);\ if (obj2<5 || obj2>(#largest_object-255) || obj2 in 1)\ return RT__Err(17,obj1,obj2);", "x=obj2; while (x~=0) { if (x==obj1) return RT__Err(18,obj1,obj2); \ x=parent(x); }\ #ifdef INFIX;\ if (obj1 has infix__watching\ || obj2 has infix__watching || (debug_flag & 15))\ print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15)\ print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\ #endif; #endif;\ @insert_obj obj1 obj2; ]", "", "", "", "" }, { /* RT__ChR: check at run-time that a proposed object remove is legal cause error and do nothing if not; otherwise remove */ "RT__ChR", "obj1;\ if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\ return RT__Err(15,obj1);", "#ifdef INFIX;\ if (obj1 has infix__watching || (debug_flag & 15))\ print \"[Removing \", (name) obj1, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15)\ print \"[Removing \", (name) obj1, \"]^\";\ #endif; #endif;\ @remove_obj obj1; ]", "", "", "", "" }, { /* RT__ChG: check at run-time that a proposed attr give is legal cause error and do nothing if not; otherwise give */ "RT__ChG", "obj1 a;\ if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\ return RT__Err(14,obj1); if (a<0 || a>=48) return RT__Err(19,obj1);\ if (obj1 has a) return;", "#ifdef INFIX;\ if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\ print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (a ~= workflag && debug_flag & 15)\ print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\ #endif; #endif;\ @set_attr obj1 a; ]", "", "", "", "" }, { /* RT__ChGt: check at run-time that a proposed attr give ~ is legal cause error and do nothing if not; otherwise give */ "RT__ChGt", "obj1 a;\ if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\ return RT__Err(14,obj1); if (a<0 || a>=48) return RT__Err(19,obj1);\ if (obj1 hasnt a) return;", "#ifdef INFIX;\ if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\ print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (a ~= workflag && debug_flag & 15)\ print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\ #endif; #endif;\ @clear_attr obj1 a; ]", "", "", "", "" }, { /* RT__ChPS: check at run-time that a proposed property set is legal cause error and do nothing if not; otherwise make it */ "RT__ChPS", "obj prop val size;\ if (obj<5 || obj>(#largest_object-255) || obj in 1 || obj.&prop==0 || (size=obj.#prop)>2 )\ return RT__Err(\"set\", obj, prop, size);\ @put_prop obj prop val;", "#ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,prop,val);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,prop,val);\ #endif; #endif;\ return val; ]", "", "", "", "" }, { /* RT__ChPR: check at run-time that a proposed property read is legal cause error and return 0 if not; otherwise read it */ "RT__ChPR", "obj prop val size;\ if (obj<5 || obj>(#largest_object-255) || (size=obj.#prop)>2)\ {RT__Err(\"read\", obj, prop, size); obj=2;}\ @get_prop obj prop -> val;", "return val; ]", "", "", "", "" }, { /* RT__TrPS: trace property settings */ "RT__TrPS", "obj prop val;\ print \"[Setting \",(name) obj,\".\",(property) prop,\ \" to \",val,\"]^\"; ]", "", "", "", "", "" }, { /* RT__ChLDB: check at run-time that it's safe to load a byte and return the byte */ "RT__ChLDB", "base offset a val;\ a=base+offset;if (Unsigned__Compare(a,#readable_memory_offset)>=0)\ return RT__Err(24);", "@loadb base offset -> val;return val; ]", "", "", "", "" }, { /* RT__ChLDW: check at run-time that it's safe to load a word and return the word */ "RT__ChLDW", "base offset a val;\ a=base+2*offset;if (Unsigned__Compare(a,#readable_memory_offset)>=0)\ return RT__Err(25);", "@loadw base offset -> val;return val; ]", "", "", "", "" }, { /* RT__ChSTB: check at run-time that it's safe to store a byte and store it */ "RT__ChSTB", "base offset val a f;\ a=base+offset;\ if (Unsigned__Compare(a,#array__start)>=0\ && Unsigned__Compare(a,#array__end)<0) f=1; else\ if (Unsigned__Compare(a,#cpv__start)>=0\ && Unsigned__Compare(a,#cpv__end)<0) f=1; else\ if (Unsigned__Compare(a,#ipv__start)>=0\ && Unsigned__Compare(a,#ipv__end)<0) f=1; else\ if (a==$0011) f=1;\ if (f==0) return RT__Err(26);", "@storeb base offset val; ]", "", "", "", "" }, { /* RT__ChSTW: check at run-time that it's safe to store a word and store it */ "RT__ChSTW", "base offset val a f;\ a=base+2*offset;\ if (Unsigned__Compare(a,#array__start)>=0\ && Unsigned__Compare(a,#array__end)<0) f=1; else\ if (Unsigned__Compare(a,#cpv__start)>=0\ && Unsigned__Compare(a,#cpv__end)<0) f=1; else\ if (Unsigned__Compare(a,#ipv__start)>=0\ && Unsigned__Compare(a,#ipv__end)<0) f=1; else\ if (a==$0010) f=1;\ if (f==0) return RT__Err(27);", "@storew base offset val; ]", "", "", "", "" }, { /* RT__ChPrintC: check at run-time that it's safe to print (char) and do so */ "RT__ChPrintC", "c fl;\ if (c==0 or 9 or 11 or 13) fl=1;\ if (c>=32 && c<=126) fl=1; if (c>=155 && c<=251) fl=1;\ if (fl==0) return RT__Err(33,c);", "@print_char c; ]", "", "", "", "" }, { /* RT__ChPrintA: check at run-time that it's safe to print (address) and do so */ "RT__ChPrintA", "a;\ if (Unsigned__Compare(a, #readable_memory_offset)>=0)\ return RT__Err(34);", "@print_addr a; ]", "", "", "", "" }, { /* RT__ChPrintS: check at run-time that it's safe to print (string) and do so */ "RT__ChPrintS", "a;\ if (Z__Region(a)~=3) return RT__Err(35);", "@print_paddr a; ]", "", "", "", "" }, { /* RT__ChPrintO: check at run-time that it's safe to print (object) and do so */ "RT__ChPrintO", "a;\ if (Z__Region(a)~=1) return RT__Err(36);", "@print_obj a; ]", "", "", "", "" } }; static VeneerRoutine VRs_g[VENEER_ROUTINES] = { { /* Box__Routine: Display the given array of text as a box quote. This is a very simple implementation; the library should provide a fancier version. */ "Box__Routine", "maxwid arr ix;\ maxwid = 0;\ glk($0086, 7);\ for (ix=0 : ix0 : ix++) {\ print (string) arr-->(ix+1);\ new_line;\ }\ glk($0086, 0);\ ]", "", "", "", "", "" }, /* This batch of routines is expected to be defined (rather better) by the Inform library: these minimal forms here are provided to prevent tiny non-library-using programs from failing to compile when certain legal syntaxes (such as <>;) are used. */ { "R_Process", "a b c; print \"Action <\", a, \" \", b, \" \", c, \">^\";\ ]", "", "", "", "", "" }, { "DefArt", "obj; print \"the \", obj; ]", "", "", "", "", "" }, { "InDefArt", "obj; print \"a \", obj; ]", "", "", "", "", "" }, { "CDefArt", "obj; print \"The \", obj; ]", "", "", "", "", "" }, { "CInDefArt", "obj; print \"A \", obj; ]", "", "", "", "", "" }, { "PrintShortName", "obj q; switch(metaclass(obj))\ { 0: print \"nothing\";\ Object: q = obj-->3; @streamstr q;\ Class: print \"class \"; q = obj-->3; @streamstr q;\ Routine: print \"(routine at \", obj, \")\";\ String: print \"(string at \", obj, \")\";\ } ]", "", "", "", "", "" }, { "EnglishNumber", "obj; print obj; ]", "", "", "", "", "" }, { /* Print__PName: Print the name of a property. */ "Print__PName", "prop ptab cla maxcom minind maxind str;\ if (prop & $FFFF0000) {\ cla = #classes_table-->(prop & $FFFF);\ print (name) cla, \"::\";\ @ushiftr prop 16 prop;\ }\ ptab = #identifiers_table;\ maxcom = ptab-->1;\ minind = INDIV_PROP_START;\ maxind = minind + ptab-->3;\ str = 0;\ if (prop >= 0 && prop < maxcom) {\ str = (ptab-->0)-->prop;\ }\ else if (prop >= minind && prop < maxind) {\ str = (ptab-->2)-->(prop-minind);\ }\ if (str)\ print (string) str;\ else\ print \"\";\ ]", "", "", "", "", "" }, /* The remaining routines make up the run-time half of the object orientation system, and need never be present for Inform 5 programs. */ { /* WV__Pr: Write a value to the property for the given object. */ "WV__Pr", "obj id val addr;\ addr = obj.&id;\ if (addr == 0) {\ RT__Err(\"write\", obj, id);\ return 0;\ }\ addr-->0 = val;\ return 0;\ ]", "", "", "", "", "" }, { /* RV__Pr: Read a value to the property for the given object. */ "RV__Pr", "obj id addr;\ addr = obj.&id;\ if (addr == 0) {\ if (id > 0 && id < INDIV_PROP_START) {\ return #cpv__start-->id;\ }\ RT__Err(\"read\", obj, id);\ return 0;\ }\ return addr-->0;\ ]", "", "", "", "", "" }, { /* CA__Pr: Call, that is, print-or-run-or-read, a property: this exactly implements obj..prop(...). Note that classes (members of Class) have 5 built-in properties inherited from Class: create, recreate, destroy, remaining and copy. Implementing these here prevents the need for a full metaclass inheritance scheme. */ "CA__Pr", "_vararg_count obj id zr s s2 z addr len m val;\ @copy sp obj;\ @copy sp id;\ _vararg_count = _vararg_count - 2;\ zr = Z__Region(obj);\ if (zr == 2) {\ if (id == call) {\ s = sender; sender = self; self = obj;\ #ifdef action; sw__var=action; #endif;\ @call obj _vararg_count z;\ self = sender; sender = s;\ return z;\ }\ jump Call__Error;\ }", " if (zr == 3) {\ if (id == print) {\ @streamstr obj; rtrue;\ }\ if (id == print_to_array) {\ if (_vararg_count >= 2) {\ @copy sp m;\ @copy sp len;\ }\ else {\ @copy sp m;\ len = $7FFFFFFF;\ }\ s2 = glk($0048);\ s = glk($0043, m+4, len-4, 1, 0);", " if (s) {\ glk($0047, s);\ @streamstr obj;\ glk($0047, s2);\ @copy $ffffffff sp;\ @copy s sp;\ @glk $0044 2 0;\ @copy sp len;\ @copy sp 0;\ m-->0 = len;\ return len;\ }\ rfalse;\ }\ jump Call__Error;\ }", " if (zr ~= 1)\ jump Call__Error;\ #ifdef DEBUG;#ifdef InformLibrary;\ if (debug_flag & 1 ~= 0) {\ debug_flag--;\ print \"[ ~\", (name) obj, \"~.\", (property) id, \"(\";\ @stkcopy _vararg_count;\ for (val=0 : val < _vararg_count : val++) {\ if (val) print \", \";\ @streamnum sp;\ }\ print \") ]^\";\ debug_flag++;\ }\ #endif;#endif;\ if (obj in Class) {\ switch (id) {\ remaining:\ return Cl__Ms(obj, id);\ copy:\ @copy sp m;\ @copy sp val;\ return Cl__Ms(obj, id, m, val);\ create, destroy, recreate:\ m = _vararg_count+2;\ @copy id sp;\ @copy obj sp;\ @call Cl__Ms m val;\ return val;\ }\ }", " addr = obj.&id;\ if (addr == 0) {\ if (id > 0 && id < INDIV_PROP_START) {\ addr = #cpv__start + 4*id;\ len = 4;\ }\ else {\ jump Call__Error;\ }\ }\ else {\ len = obj.#id;\ }\ for (m=0 : 4*mm;\ if (val == -1) rfalse;\ switch (Z__Region(val)) {\ 2:\ s = sender; sender = self; self = obj; s2 = sw__var;\ #ifdef LibSerial;\ if (id==life) sw__var=reason_code; else sw__var=action;\ #endif;", " @stkcopy _vararg_count;\ @call val _vararg_count z;\ self = sender; sender = s; sw__var = s2;\ if (z ~= 0) return z;\ 3:\ @streamstr val;\ new_line;\ rtrue;\ default:\ return val;\ }\ }\ rfalse;\ .Call__Error;\ RT__Err(\"send message\", obj, id);\ rfalse;\ ]" }, { /* IB__Pr: ++(individual property) */ "IB__Pr", "obj identifier x;\ x = obj.&identifier;\ if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)+1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\ #endif; #endif;\ return ++(x-->0);\ ]", "", "", "", "", "" }, { /* IA__Pr: (individual property)++ */ "IA__Pr", "obj identifier x;\ x = obj.&identifier;\ if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15))\ RT__TrPS(obj,identifier,(x-->0)+1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\ #endif; #endif;\ return (x-->0)++;\ ]", "", "", "", "", "" }, { /* DB__Pr: --(individual property) */ "DB__Pr", "obj identifier x;\ x = obj.&identifier;\ if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\ #endif; #endif;\ return --(x-->0);\ ]", "", "", "", "", "" }, { /* DA__Pr: (individual property)-- */ "DA__Pr", "obj identifier x;\ x = obj.&identifier;\ if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\ #endif; #endif;\ return (x-->0)--;\ ]", "", "", "", "", "" }, { /* RA__Pr: Read the property address of a given property value. Returns zero if it isn't provided by the object. This understands all the same concerns as RL__Pr(). */ "RA__Pr", "obj id cla prop ix;\ if (id & $FFFF0000) {\ cla = #classes_table-->(id & $FFFF);\ if (~~(obj ofclass cla)) return 0;\ @ushiftr id 16 id;\ obj = cla;\ }\ prop = CP__Tab(obj, id);\ if (prop==0) return 0;\ if (obj in Class && cla == 0) {\ if (id < INDIV_PROP_START || id >= INDIV_PROP_START+8)\ return 0;\ }\ if (self ~= obj) {\ @aloadbit prop 72 ix;\ if (ix) return 0;\ }\ return prop-->1;\ ]", "", "", "", "", "" }, { /* RL__Pr: Read the property length of a given property value. Returns zero if it isn't provided by the object. This understands inherited values (of the form class::prop) as well as simple property ids and the special metaclass methods. It also knows that private properties can only be read if (self == obj). */ "RL__Pr", "obj id cla prop ix;\ if (id & $FFFF0000) {\ cla = #classes_table-->(id & $FFFF);\ if (~~(obj ofclass cla)) return 0;\ @ushiftr id 16 id;\ obj = cla;\ }\ prop = CP__Tab(obj, id);\ if (prop==0) return 0;\ if (obj in Class && cla == 0) {\ if (id < INDIV_PROP_START || id >= INDIV_PROP_START+8)\ return 0;\ }\ if (self ~= obj) {\ @aloadbit prop 72 ix;\ if (ix) return 0;\ }\ @aloads prop 1 ix;\ return WORDSIZE * ix;\ ]", "", "", "", "", "" }, { /* RA__Sc: Implement the \"superclass\" (::) operator. This returns an compound property identifier, which is a 32-bit value. */ "RA__Sc", "cla id j;\ if ((cla notin Class) && (cla ~= Class or String or Routine or Object)) {\ RT__Err(\"be a '::' superclass\", cla, -1);\ rfalse;\ }\ for (j=0 : #classes_table-->j ~= 0 : j++) {\ if (cla == #classes_table-->j) {\ return (id * $10000 + j);\ }\ }\ RT__Err(\"make use of\", cla, id);\ rfalse;\ ]", "", "", "", "", "" }, { /* OP__Pr: Test whether the given object provides the given property. This winds up calling RA__Pr(). */ "OP__Pr", "obj id zr;\ zr = Z__Region(obj);\ if (zr == 3) {\ if (id == print or print_to_array) rtrue;\ rfalse;\ }\ if (zr == 2) {\ if (id == call) rtrue;\ rfalse;\ }\ if (zr ~= 1) rfalse;\ if (id >= INDIV_PROP_START && id < INDIV_PROP_START+8) {\ if (obj in Class) rtrue;\ }\ if (obj.&id ~= 0)\ rtrue;\ rfalse;\ ]", "", "", "", "", "" }, { /* OC__Cl: Test whether the given object is of the given class. (implements the OfClass operator.) */ "OC__Cl", "obj cla zr jx inlist inlistlen;\ zr = Z__Region(obj);\ if (zr == 3) {\ if (cla == String) rtrue;\ rfalse;\ }\ if (zr == 2) {\ if (cla == Routine) rtrue;\ rfalse;\ }\ if (zr ~= 1) rfalse;\ if (cla == Class) {\ if (obj in Class\ || obj == Class or String or Routine or Object)\ rtrue;\ rfalse;\ }\ if (cla == Object) {\ if (obj in Class\ || obj == Class or String or Routine or Object)\ rfalse;\ rtrue;\ }\ if (cla == String or Routine) rfalse;\ if (cla notin Class) {\ RT__Err(\"apply 'ofclass' for\", cla, -1);\ rfalse;\ }\ inlist = obj.&2;\ if (inlist == 0) rfalse;\ inlistlen = (obj.#2) / WORDSIZE;\ for (jx=0 : jxjx == cla) rtrue;\ }\ rfalse;\ ]", "", "", "", "", "" }, { /* Copy__Primitive: Routine to \"deep copy\" objects. */ "Copy__Primitive", "o1 o2 p1 p2 pcount i j propid proplen val pa1 pa2;\ for (i=1 : i<=NUM_ATTR_BYTES : i++) {\ o1->i = o2->i;\ }\ p2 = o2-->4;\ pcount = p2-->0;\ p2 = p2+4;\ for (i=0 : i1;\ pa2 = p2-->1;\ for (j=0 : jj = pa2-->j;\ }\ }\ p2 = p2+10;\ }\ ]", "", "", "", "", "" }, { /* RT__Err: for run-time errors occurring in the above: e.g., an attempt to write to a non-existent individual property */ "RT__Err", "crime obj id size p q;\ print \"^[** Programming error: \";\ if (crime<0) jump RErr;\ if (crime==1) { print \"class \"; q = obj-->3; @streamstr q;\ \": 'create' can have 0 to 3 parameters only **]\";}\ if (crime == 40) \"tried to change printing variable \",\ obj, \"; must be 0 to \", #dynam_string_table-->0-1, \" **]\";\ if (crime == 32) \"objectloop broken because the object \",\ (name) obj, \" was moved while the loop passed through it **]\";\ if (crime == 33) \"tried to print (char) \", obj,\ \", which is not a valid Glk character code for output **]\";\ if (crime == 34) \"tried to print (address) on something not the \",\ \"address of a dict word **]\";\ if (crime == 35) \"tried to print (string) on something not a \",\ \"string **]\";\ if (crime == 36) \"tried to print (object) on something not an \",\ \"object or class **]\";", "if (crime < 32) { print \"tried to \";\ if (crime >= 28) { if (crime==28 or 29) print \"read from \";\ else print \"write to \";\ if (crime==29 or 31) print \"-\"; print \"->\", obj,\ \" in the\"; switch(size&7){0,1:q=0; 2:print \" string\";\ q=1; 3:print \" table\";q=1; 4:print \" buffer\";q=WORDSIZE;} \ if(size&16) print\" (->)\"; if(size&8) print\" (-->)\";\ \" array ~\", (string) #array_names_offset-->(p+1),\ \"~, which has entries \", q, \" up to \",id,\" **]\"; }\ if (crime >= 24 && crime <=27) { if (crime<=25) print \"read\";\ else print \"write\"; print \" outside memory using \";\ switch(crime) { 24,26:\"-> **]\"; 25,27:\"--> **]\"; } }\ if (crime < 4) print \"test \"; else\ if (crime < 12 || crime > 20) print \"find the \"; else\ if (crime < 14) print \"use \";\ if (crime==20) \"divide by zero **]\"; print \"~\";\ switch(crime) {\ 2: print \"in~ or ~notin\"; 3: print \"has~ or ~hasnt\";\ 4: print \"parent\"; 5: print \"eldest\"; 6: print \"child\";\ 7: print \"younger\"; 8: print \"sibling\"; 9: print \"children\";\ 10: print \"youngest\"; 11: print \"elder\";\ 12: print \"objectloop\"; 13: print \"}~ at end of ~objectloop\";\ 14: \"give~ an attribute to \", (name) obj, \" **]\";\ 15: \"remove~ \", (name) obj, \" **]\";", "16,17,18: print \"move~ \", (name) obj, \" to \", (name) id;\ if (crime==18) { print \", which would make a loop: \",(name) obj;\ p=id; if (p==obj) p=obj;\ else do { print \" in \", (name) p; p=parent(p);} until (p==obj);\ \" in \", (name) p, \" **]\"; }\ \" **]\"; 19: \"give~ or test ~has~ or ~hasnt~ with a non-attribute"\ " on the object \",(name) obj,\" **]\";\ 21: print \".&\"; 22: print \".#\"; 23: print \".\"; }\ \"~ of \", (name) obj, \" **]\"; }", ".RErr; if (obj==0 || obj->0>=$70 && obj->0<=$7F) {\ if (obj && obj in Class) print \"class \";\ if (obj) print (object) obj;else print \"nothing\";print\" \";}\ print \"(object number \", obj, \") \";\ if (id<0) print \"is not of class \", (name) -id;", "else\ { print \" has no property \", (property) id;\ p = #identifiers_table;\ size = INDIV_PROP_START + p-->3;\ if (id<0 || id>=size)\ print \" (and nor has any other object)\";\ }\ print \" to \", (string) crime, \" **]^\";\ ]", "" }, { /* Z__Region: Determines whether a value is: 1 an object number 2 a code address 3 a string address 0 none of the above */ "Z__Region", "addr tb endmem;\ if (addr<36) rfalse;\ @getmemsize endmem;\ @jgeu addr endmem?outrange;\ tb=addr->0;\ if (tb >= $E0) return 3;\ if (tb >= $C0) return 2;\ if (tb >= $70 && tb <= $7F && addr >= (0-->2)) return 1;\ .outrange;\ rfalse;\ ]", "", "", "", "", "" }, { /* Unsigned__Compare: returns 1 if x>y, 0 if x=y, -1 if x=0) return 1;\ if (x>=0 && y<0) return -1;\ u = x&$7fffffff; v= y&$7fffffff;\ if (u>v) return 1;\ return -1;\ ]", "", "", "", "", "" }, { /* Meta__class: returns the metaclass of an object */ "Meta__class", "obj;\ switch(Z__Region(obj))\ { 2: return Routine;\ 3: return String;\ 1: if (obj in Class\ || obj == Class or String or Routine or Object)\ return Class;\ return Object;\ }\ rfalse;\ ]", "", "", "", "", "" }, { /* CP__Tab: Search a property table for the given identifier. The definition here is a bit different from the Z-code veneer. This just searches the property table of obj for an entry with the given identifier. It return the address of the property entry, or 0 if nothing found. (Remember that the value returned is not the address of the property *data*; it's the structure which contains the address/length/flags.) */ "CP__Tab", "obj id otab max res;\ if (Z__Region(obj)~=1) {RT__Err(23, obj); rfalse;}\ otab = obj-->4;\ if (otab == 0) return 0;\ max = otab-->0;\ otab = otab+4;\ @binarysearch id 2 otab 10 max 0 0 res;\ return res;\ ]", "", "", "", "", "" }, { /* Cl__Ms: Implements the five message-receiving properties of Classes. */ "Cl__Ms", "_vararg_count obj id a b x y;\ @copy sp obj;\ @copy sp id;\ _vararg_count = _vararg_count - 2;\ switch (id) {\ create:\ if (children(obj) <= 1) rfalse;\ x = child(obj);\ remove x;\ if (x provides create) {\ @copy create sp;\ @copy x sp;\ y = _vararg_count + 2;\ @call CA__Pr y 0;\ }\ return x;\ recreate:\ @copy sp a;\ _vararg_count--;\ if (~~(a ofclass obj)) {\ RT__Err(\"recreate\", a, -obj);\ rfalse;\ }\ if (a provides destroy)\ a.destroy();\ Copy__Primitive(a, child(obj));\ if (a provides create) {\ @copy create sp;\ @copy a sp;\ y = _vararg_count + 2;\ @call CA__Pr y 0;\ }\ rfalse;\ destroy:\ @copy sp a;\ _vararg_count--;\ if (~~(a ofclass obj)) {\ RT__Err(\"destroy\", a, -obj);\ rfalse;\ }\ if (a provides destroy)\ a.destroy();\ Copy__Primitive(a, child(obj));\ move a to obj;\ rfalse;\ remaining:\ return children(obj)-1;\ copy:\ @copy sp a;\ @copy sp b;\ _vararg_count = _vararg_count - 2;\ if (~~(a ofclass obj)) {\ RT__Err(\"copy\", a, -obj);\ rfalse;\ }\ if (~~(b ofclass obj)) {\ RT__Err(\"copy\", b, -obj);\ rfalse;\ }\ Copy__Primitive(a, b);\ rfalse;\ }\ ]", "", "", "", "", "" }, { /* RT__ChT: Check at run-time that a proposed object move is legal. Cause error and do nothing if not; otherwise move */ "RT__ChT", "obj1 obj2 ix;\ if (obj1==0 || Z__Region(obj1)~=1\ || (obj1 == Class or String or Routine or Object) || obj1 in Class)\ return RT__Err(16, obj1, obj2);\ if (obj2==0 || Z__Region(obj2)~=1\ || (obj2 == Class or String or Routine or Object) || obj2 in Class)\ return RT__Err(17, obj1, obj2);\ ix = obj2;\ while (ix ~= 0) {\ if (ix==obj1) return RT__Err(18, obj1, obj2);\ ix = parent(ix);\ }\ #ifdef INFIX;\ if (obj1 has infix__watching\ || obj2 has infix__watching || (debug_flag & 15))\ print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15)\ print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\ #endif; #endif;\ OB__Move(obj1, obj2);\ ]", "", "", "", "", "" }, { /* RT__ChR: Check at run-time that a proposed object remove is legal. Cause error and do nothing if not; otherwise remove */ "RT__ChR", "obj1;\ if (obj1==0 || Z__Region(obj1)~=1\ || (obj1 == Class or String or Routine or Object) || obj1 in Class)\ return RT__Err(15, obj1);\ #ifdef INFIX;\ if (obj1 has infix__watching || (debug_flag & 15))\ print \"[Removing \", (name) obj1, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15)\ print \"[Removing \", (name) obj1, \"]^\";\ #endif; #endif;\ OB__Remove(obj1);\ ]", "", "", "", "", "" }, { /* RT__ChG: check at run-time that a proposed attr give is legal cause error and do nothing if not; otherwise give */ "RT__ChG", "obj1 a;\ if (Z__Region(obj1) ~= 1) return RT__Err(14,obj1);\ if (obj1 in Class || obj1 == Class or String or Routine or Object)\ return RT__Err(14,obj1);\ if (a<0 || a>=NUM_ATTR_BYTES*8) return RT__Err(19,obj1);\ if (obj1 has a) return;", "#ifdef INFIX;\ if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\ print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (a ~= workflag && debug_flag & 15)\ print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\ #endif; #endif;\ give obj1 a; ]", "", "", "", "" }, { /* RT__ChGt: check at run-time that a proposed attr give ~ is legal cause error and do nothing if not; otherwise give */ "RT__ChGt", "obj1 a;\ if (Z__Region(obj1) ~= 1) return RT__Err(14,obj1);\ if (obj1 in Class || obj1 == Class or String or Routine or Object)\ return RT__Err(14,obj1);\ if (a<0 || a>=NUM_ATTR_BYTES*8) return RT__Err(19,obj1);\ if (obj1 hasnt a) return;", "#ifdef INFIX;\ if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\ print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\ #ifnot; #ifdef DEBUG;\ if (a ~= workflag && debug_flag & 15)\ print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\ #endif; #endif;\ give obj1 ~a; ]", "", "", "", "" }, { /* RT__ChPS: Check at run-time that a proposed property set is legal. Cause error and do nothing if not; otherwise make it. */ "RT__ChPS", "obj prop val res;\ if (obj==0 || Z__Region(obj)~=1\ || (obj == Class or String or Routine or Object) || obj in Class)\ return RT__Err(\"set\", obj, prop);\ res = WV__Pr(obj, prop, val);\ #ifdef INFIX;\ if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,prop,val);\ #ifnot; #ifdef DEBUG;\ if (debug_flag & 15) RT__TrPS(obj,prop,val);\ #endif; #endif;\ return res;\ ]", "", "", "", "", "" }, { /* RT__ChPR: check at run-time that a proposed property read is legal. cause error and return 0 if not; otherwise read it */ "RT__ChPR", "obj prop val;\ if (obj==0 or Class or String or Routine or Object || Z_Region(obj)~=1 )\ {RT__Err(\"read\", obj, prop); obj=2;}\ val = RV__Pr(obj, prop);", "return val; ]", "", "", "", "" }, { /* RT__TrPS: trace property settings */ "RT__TrPS", "obj prop val;\ print \"[Setting \",(name) obj,\".\",(property) prop,\ \" to \",val,\"]^\"; ]", "", "", "", "", "" }, { /* RT__ChLDB: Check at run-time that it's safe to load a byte and return the byte. */ "RT__ChLDB", "base offset a b val;\ a=base+offset;\ @getmemsize b;\ if (Unsigned__Compare(a, b) >= 0)\ return RT__Err(24);\ @aloadb base offset val;\ return val;\ ]", "", "", "", "", "" }, { /* RT__ChLDW: Check at run-time that it's safe to load a word and return the word */ "RT__ChLDW", "base offset a b val;\ a=base+WORDSIZE*offset;\ @getmemsize b;\ if (Unsigned__Compare(a, b) >= 0)\ return RT__Err(25);\ @aload base offset val;\ return val;\ ]", "", "", "", "", "" }, { /* RT__ChSTB: Check at run-time that it's safe to store a byte and store it */ "RT__ChSTB", "base offset val a b;\ a=base+offset;\ @getmemsize b;\ if (Unsigned__Compare(a, b) >= 0) jump ChSTB_Fail;\ @aload 0 2 b;\ if (Unsigned__Compare(a, b) < 0) jump ChSTB_Fail;\ @astoreb base offset val;\ return;\ .ChSTB_Fail;\ return RT__Err(26);\ ]", "", "", "", "", "" }, { /* RT__ChSTW: Check at run-time that it's safe to store a word and store it */ "RT__ChSTW", "base offset val a b;\ a=base+WORDSIZE*offset;\ @getmemsize b;\ if (Unsigned__Compare(a, b) >= 0) jump ChSTW_Fail;\ @aload 0 2 b;\ if (Unsigned__Compare(a, b) < 0) jump ChSTW_Fail;\ @astore base offset val;\ return;\ .ChSTW_Fail;\ return RT__Err(27);\ ]", "", "", "", "", "" }, { /* RT__ChPrintC: Check at run-time that it's safe to print (char) and do so. */ "RT__ChPrintC", "c;\ if (c<10 || (c>10 && c<32) || (c>126 && c<160) || c>255)\ return RT__Err(33,c);\ @streamchar c;\ ]", "", "", "", "", "" }, { /* RT__ChPrintA: Check at run-time that it's safe to print (address) and do so. */ "RT__ChPrintA", "addr endmem;\ if (addr<36)\ return RT__Err(34);\ @getmemsize endmem;\ if (Unsigned__Compare(addr, endmem) >= 0)\ return RT__Err(34);\ if (addr->0 ~= $60)\ return RT__Err(34);\ Print__Addr(addr);\ ]", "", "", "", "", "" }, { /* Check at run-time that it's safe to print (string) and do so. */ "RT__ChPrintS", "str;\ if (Z__Region(str) ~= 3)\ return RT__Err(35);\ @streamstr str;\ ]", "", "", "", "", "" }, { /* Check at run-time that it's safe to print (object) and do so. */ "RT__ChPrintO", "obj;\ if (Z__Region(obj) ~= 1)\ return RT__Err(36);\ @aload obj 3 sp; @streamstr sp;\ ]", "", "", "", "", "" }, { /* OB__Move: Move an object within the object tree. This does no more error checking than the Z-code \"move\" opcode. */ "OB__Move", "obj dest par chi sib;\ par = obj-->5;\ if (par ~= 0) {\ chi = par-->7;\ if (chi == obj) {\ par-->7 = obj-->6;\ }\ else {\ while (1) {\ sib = chi-->6;\ if (sib == obj)\ break;\ chi = sib;\ }\ chi-->6 = obj-->6;\ }\ }\ obj-->6 = dest-->7;\ obj-->5 = dest;\ dest-->7 = obj;\ rfalse;\ ]", "", "", "", "", "" }, { /* OB__Remove: Remove an object from the tree. This does no more error checking than the Z-code \"remove\" opcode. -->5 is parent; -->6 is sibling; -->7 is child. */ "OB__Remove", "obj par chi sib;\ par = obj-->5;\ if (par == 0)\ rfalse;\ chi = par-->7;\ if (chi == obj) {\ par-->7 = obj-->6;\ }\ else {\ while (1) {\ sib = chi-->6;\ if (sib == obj)\ break;\ chi = sib;\ }\ chi-->6 = obj-->6;\ }\ obj-->6 = 0;\ obj-->5 = 0;\ rfalse;\ ]", "", "", "", "", "" }, { /* Print__Addr: Handle the print (address) statement. In Glulx, this behaves differently than on the Z-machine; it can *only* print dictionary words. */ "Print__Addr", "addr ix ch;\ if (addr->0 ~= $60) {\ print \"(\", addr, \": not dict word)\";\ return;\ }\ for (ix=1 : ix <= DICT_WORD_SIZE : ix++) {\ ch = addr->ix;\ if (ch == 0)\ return;\ print (char) ch;\ }\ ]", "", "", "", "", "" }, { /* Glk__Wrap: This is a wrapper for the @glk opcode. It just passes all its arguments into the Glk dispatcher, and returns the Glk call result. */ "Glk__Wrap", "_vararg_count callid retval;\ @copy sp callid;\ _vararg_count = _vararg_count - 1;\ @glk callid _vararg_count retval;\ return retval;\ ]", "", "", "", "", "" }, { /* Dynam__String: Set dynamic string (printing variable) num to the given val, which can be any string or function. */ "Dynam__String", "num val;\ if (num < 0 || num >= #dynam_string_table-->0)\ return RT__Err(40, num);\ (#dynam_string_table)-->(num+1) = val;\ ]", "", "", "", "", "" } }; static void mark_as_needed_z(int code) { ASSERT_ZCODE(); if (veneer_routine_needs_compilation[code] == VR_UNUSED) { veneer_routine_needs_compilation[code] = VR_CALLED; /* Here each routine must mark every veneer routine it explicitly calls as needed */ switch(code) { case WV__Pr_VR: mark_as_needed_z(RT__TrPS_VR); mark_as_needed_z(RT__Err_VR); return; case RV__Pr_VR: mark_as_needed_z(RT__Err_VR); return; case CA__Pr_VR: mark_as_needed_z(Z__Region_VR); mark_as_needed_z(Cl__Ms_VR); mark_as_needed_z(RT__Err_VR); return; case IB__Pr_VR: case IA__Pr_VR: case DB__Pr_VR: case DA__Pr_VR: mark_as_needed_z(RT__Err_VR); mark_as_needed_z(RT__TrPS_VR); return; case RA__Pr_VR: mark_as_needed_z(CP__Tab_VR); return; case RA__Sc_VR: mark_as_needed_z(RT__Err_VR); return; case OP__Pr_VR: mark_as_needed_z(Z__Region_VR); return; case OC__Cl_VR: mark_as_needed_z(Z__Region_VR); mark_as_needed_z(RT__Err_VR); return; case Z__Region_VR: mark_as_needed_z(Unsigned__Compare_VR); return; case Metaclass_VR: mark_as_needed_z(Z__Region_VR); return; case Cl__Ms_VR: mark_as_needed_z(RT__Err_VR); mark_as_needed_z(Copy__Primitive_VR); return; case RT__ChR_VR: case RT__ChT_VR: case RT__ChG_VR: case RT__ChGt_VR: case RT__ChPR_VR: mark_as_needed_z(RT__Err_VR); return; case RT__ChPS_VR: mark_as_needed_z(RT__Err_VR); mark_as_needed_z(RT__TrPS_VR); return; case RT__ChLDB_VR: case RT__ChLDW_VR: case RT__ChSTB_VR: case RT__ChSTW_VR: mark_as_needed_z(Unsigned__Compare_VR); mark_as_needed_z(RT__Err_VR); return; case RT__ChPrintC_VR: mark_as_needed_z(RT__Err_VR); return; case RT__ChPrintA_VR: mark_as_needed_z(Unsigned__Compare_VR); mark_as_needed_z(RT__Err_VR); return; case RT__ChPrintS_VR: case RT__ChPrintO_VR: mark_as_needed_z(RT__Err_VR); mark_as_needed_z(Z__Region_VR); return; } } } static void mark_as_needed_g(int code) { ASSERT_GLULX(); if (veneer_routine_needs_compilation[code] == VR_UNUSED) { veneer_routine_needs_compilation[code] = VR_CALLED; /* Here each routine must mark every veneer routine it explicitly calls as needed */ switch(code) { case PrintShortName_VR: mark_as_needed_g(Metaclass_VR); return; case Print__Pname_VR: mark_as_needed_g(PrintShortName_VR); return; case WV__Pr_VR: mark_as_needed_g(RA__Pr_VR); mark_as_needed_g(RT__TrPS_VR); mark_as_needed_g(RT__Err_VR); return; case RV__Pr_VR: mark_as_needed_g(RA__Pr_VR); mark_as_needed_g(RT__Err_VR); return; case CA__Pr_VR: mark_as_needed_g(RA__Pr_VR); mark_as_needed_g(RL__Pr_VR); mark_as_needed_g(PrintShortName_VR); mark_as_needed_g(Print__Pname_VR); mark_as_needed_g(Z__Region_VR); mark_as_needed_g(Cl__Ms_VR); mark_as_needed_g(Glk__Wrap_VR); mark_as_needed_g(RT__Err_VR); return; case IB__Pr_VR: case IA__Pr_VR: case DB__Pr_VR: case DA__Pr_VR: mark_as_needed_g(RT__Err_VR); mark_as_needed_g(RT__TrPS_VR); return; case RA__Pr_VR: mark_as_needed_g(OC__Cl_VR); mark_as_needed_g(CP__Tab_VR); return; case RL__Pr_VR: mark_as_needed_g(OC__Cl_VR); mark_as_needed_g(CP__Tab_VR); return; case RA__Sc_VR: mark_as_needed_g(OC__Cl_VR); mark_as_needed_g(RT__Err_VR); return; case OP__Pr_VR: mark_as_needed_g(RA__Pr_VR); mark_as_needed_g(Z__Region_VR); return; case OC__Cl_VR: mark_as_needed_g(RA__Pr_VR); mark_as_needed_g(RL__Pr_VR); mark_as_needed_g(Z__Region_VR); mark_as_needed_g(RT__Err_VR); return; case Copy__Primitive_VR: mark_as_needed_g(CP__Tab_VR); return; case Z__Region_VR: mark_as_needed_g(Unsigned__Compare_VR); return; case CP__Tab_VR: case Metaclass_VR: mark_as_needed_g(Z__Region_VR); return; case Cl__Ms_VR: mark_as_needed_g(OC__Cl_VR); mark_as_needed_g(OP__Pr_VR); mark_as_needed_g(RT__Err_VR); mark_as_needed_g(Copy__Primitive_VR); mark_as_needed_g(OB__Remove_VR); mark_as_needed_g(OB__Move_VR); return; case RT__ChG_VR: case RT__ChGt_VR: mark_as_needed_g(RT__Err_VR); return; case RT__ChR_VR: mark_as_needed_g(RT__Err_VR); mark_as_needed_g(Z__Region_VR); mark_as_needed_g(OB__Remove_VR); return; case RT__ChT_VR: mark_as_needed_g(RT__Err_VR); mark_as_needed_g(Z__Region_VR); mark_as_needed_g(OB__Move_VR); return; case RT__ChPS_VR: mark_as_needed_g(RT__Err_VR); mark_as_needed_g(RT__TrPS_VR); mark_as_needed_g(WV__Pr_VR); return; case RT__ChPR_VR: mark_as_needed_g(RT__Err_VR); mark_as_needed_g(RV__Pr_VR); return; case RT__ChLDB_VR: case RT__ChLDW_VR: case RT__ChSTB_VR: case RT__ChSTW_VR: mark_as_needed_g(Unsigned__Compare_VR); mark_as_needed_g(RT__Err_VR); return; case RT__ChPrintC_VR: mark_as_needed_g(RT__Err_VR); return; case RT__ChPrintA_VR: mark_as_needed_g(Unsigned__Compare_VR); mark_as_needed_g(RT__Err_VR); mark_as_needed_g(Print__Addr_VR); return; case RT__ChPrintS_VR: case RT__ChPrintO_VR: mark_as_needed_g(RT__Err_VR); mark_as_needed_g(Z__Region_VR); return; case Print__Addr_VR: mark_as_needed_g(RT__Err_VR); return; case Dynam__String_VR: mark_as_needed_g(RT__Err_VR); return; } } } extern assembly_operand veneer_routine(int code) { assembly_operand AO; if (!glulx_mode) { AO.type = LONG_CONSTANT_OT; AO.marker = VROUTINE_MV; AO.value = code; mark_as_needed_z(code); } else { AO.type = CONSTANT_OT; AO.marker = VROUTINE_MV; AO.value = code; mark_as_needed_g(code); } return(AO); } static void compile_symbol_table_routine(void) { int32 j, nl, arrays_l, routines_l, constants_l; assembly_operand AO, AO2, AO3; dbgl null_dbgl; null_dbgl.b1 = 0; null_dbgl.b2 = 0; null_dbgl.b3 = 0; null_dbgl.cc = 0; veneer_mode = TRUE; j = symbol_index("Symb__Tab", -1); assign_symbol(j, assemble_routine_header(2, FALSE, "Symb__Tab", &null_dbgl, FALSE, j), ROUTINE_T); sflags[j] |= SYSTEM_SFLAG + USED_SFLAG; if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG; if (!glulx_mode) { if (define_INFIX_switch == FALSE) { assemblez_0(rfalse_zc); variable_usage[1] = TRUE; variable_usage[2] = TRUE; assemble_routine_end(FALSE, &null_dbgl); veneer_mode = FALSE; return; } AO.value = 1; AO.type = VARIABLE_OT; AO.marker = 0; AO2.type = SHORT_CONSTANT_OT; AO2.marker = 0; AO3.type = LONG_CONSTANT_OT; AO3.marker = 0; arrays_l = next_label++; routines_l = next_label++; constants_l = next_label++; sequence_point_follows = FALSE; AO2.value = 1; assemblez_2_branch(je_zc, AO, AO2, arrays_l, TRUE); sequence_point_follows = FALSE; AO2.value = 2; assemblez_2_branch(je_zc, AO, AO2, routines_l, TRUE); sequence_point_follows = FALSE; AO2.value = 3; assemblez_2_branch(je_zc, AO, AO2, constants_l, TRUE); sequence_point_follows = FALSE; assemblez_0(rtrue_zc); assemble_label_no(arrays_l); AO.value = 2; for (j=0; j