veneer.c

   1 /* ------------------------------------------------------------------------- */
   2 /*   "veneer" : Compiling the run-time "veneer" of any routines invoked      */
   3 /*              by the compiler (e.g. DefArt) which the program doesn't      */
   4 /*              provide                                                      */
   5 /*                                                                           */
   6 /*   Part of Inform 6.33                                                     */
   7 /*   copyright (c) Graham Nelson 1993 - 2014                                 */
   8 /*                                                                           */
   9 /* ------------------------------------------------------------------------- */
  10
  11 #include "header.h"
  12
  13 int veneer_mode;                      /*  Is the code currently being
  14                                           compiled from the veneer?          */
  15
  16 static debug_locations null_debug_locations =
  17     { { 0, 0, 0, 0, 0, 0, 0 }, NULL, 0 };
  18
  19 extern void compile_initial_routine(void)
  20 {
  21     /*  The first routine present in memory in any Inform game, beginning
  22         at the code area start position, always has 0 local variables
  23         (since the interpreter begins execution with an empty stack frame):
  24         and it must "quit" rather than "return".
  25
  26         In order not to impose these restrictions on "Main", we compile a
  27         trivial routine consisting of a call to "Main" followed by "quit".   */
  28
  29   int32 j;
  30     assembly_operand AO;
  31
  32     j = symbol_index("Main__", -1);
  33     assign_symbol(j,
  34         assemble_routine_header(0, FALSE, "Main__", FALSE, j),
  35         ROUTINE_T);
  36     sflags[j] |= SYSTEM_SFLAG + USED_SFLAG;
  37     if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG;
  38
  39     if (!glulx_mode) {
  40
  41         AO.value = 0; AO.type = LONG_CONSTANT_OT; AO.marker = MAIN_MV;
  42
  43         sequence_point_follows = FALSE;
  44
  45         if (version_number > 3)
  46             assemblez_1_to(call_vs_zc, AO, temp_var1);
  47         else
  48             assemblez_1_to(call_zc, AO, temp_var1);
  49
  50         assemblez_0(quit_zc);
  51
  52     }
  53     else {
  54
  55         AO.value = 0; AO.type = CONSTANT_OT; AO.marker = MAIN_MV;
  56
  57         sequence_point_follows = FALSE;
  58
  59         assembleg_3(call_gc, AO, zero_operand, zero_operand);
  60         assembleg_1(return_gc, zero_operand);
  61
  62     }
  63
  64     assemble_routine_end(FALSE, null_debug_locations);
  65 }
  66
  67 /* ------------------------------------------------------------------------- */
  68 /*   The rest of the veneer is applied at the end of the pass, as required.  */
  69 /* ------------------------------------------------------------------------- */
  70
  71 static int veneer_routine_needs_compilation[VENEER_ROUTINES];
  72 int32 veneer_routine_address[VENEER_ROUTINES];
  73 static int veneer_symbols_base;
  74
  75 #define VR_UNUSED      0
  76 #define VR_CALLED      1
  77 #define VR_COMPILED    2
  78
  79 typedef struct VeneerRoutine_s
  80 {   char *name;
  81     char *source1;
  82     char *source2;
  83     char *source3;
  84     char *source4;
  85     char *source5;
  86     char *source6;
  87 } VeneerRoutine;
  88
  89 static char *veneer_source_area;
  90
  91 static VeneerRoutine VRs_z[VENEER_ROUTINES] =
  92 {
  93     /*  Box__Routine:  the only veneer routine used in the implementation of
  94                        an actual statement ("box", of course), written in a
  95                        hybrid of Inform and assembly language.  Note the
  96                        transcription of the box text to the transcript
  97                        output stream (-1, or $ffff).                         */
  98
  99     {   "Box__Routine",
 100         "maxw table n w w2 line lc t;\
 101          n = table --> 0;\
 102          @add n 6 -> sp;\
 103          @split_window sp;\
 104          @set_window 1;\
 105          w = 0 -> 33;\
 106          if (w == 0) w=80;\
 107          w2 = (w - maxw)/2;\
 108          style reverse;\
 109          @sub w2 2 -> w;\
 110          line = 5;\
 111          lc = 1;\
 112          @set_cursor 4 w;\
 113          spaces maxw + 4;",
 114         "do\
 115          {   @set_cursor line w;\
 116              spaces maxw + 4;\
 117              @set_cursor line w2;\
 118              t = table --> lc;\
 119              if (t~=0) print (string) t;\
 120              line++; lc++;\
 121          } until (lc > n);\
 122          @set_cursor line w;\
 123          spaces maxw + 4;\
 124          @buffer_mode 1;\
 125          style roman;\
 126          @set_window 0;\
 127          @split_window 1;\
 128          @output_stream $ffff;\
 129          print \"[ \";\
 130          lc = 1;",
 131         "do\
 132          {   w = table --> lc;\
 133              if (w ~= 0) print (string) w;\
 134              lc++;\
 135              if (lc > n)\
 136              {   print \"]^^\";\
 137                  break;\
 138              }\
 139              print \"^  \";\
 140          } until (false);\
 141          @output_stream 1;\
 142          ]", "", "", ""
 143     },
 144
 145     /*  This batch of routines is expected to be defined (rather better) by
 146         the Inform library: these minimal forms here are provided to prevent
 147         tiny non-library-using programs from failing to compile when certain
 148         legal syntaxes (such as <<Action a b>>;) are used.                   */
 149
 150     {   "R_Process",
 151         "a b c d; print \"Action <\", a, \" \", b, \" \", c;\
 152          if (d) print \", \", d; print \">^\";\
 153          ]", "", "", "", "", ""
 154     },
 155     {   "DefArt",
 156         "obj; print \"the \", obj; ]", "", "", "", "", ""
 157     },
 158     {   "InDefArt",
 159         "obj; print \"a \", obj; ]", "", "", "", "", ""
 160     },
 161     {   "CDefArt",
 162         "obj; print \"The \", obj; ]", "", "", "", "", ""
 163     },
 164     {   "CInDefArt",
 165         "obj; print \"A \", obj; ]", "", "", "", "", ""
 166     },
 167     {   "PrintShortName",
 168         "obj; switch(metaclass(obj))\
 169          {   0: print \"nothing\";\
 170              Object: @print_obj obj;\
 171              Class: print \"class \"; @print_obj obj;\
 172              Routine: print \"(routine at \", obj, \")\";\
 173              String: print \"(string at \", obj, \")\";\
 174          } ]", "", "", "", "", ""
 175     },
 176     {   "EnglishNumber",
 177         "obj; print obj; ]", "", "", "", "", ""
 178     },
 179     {   "Print__PName",
 180         "prop p size cla i;\
 181          if (prop & $c000)\
 182          {   cla = #classes_table-->(prop & $ff);\
 183              print (name) cla, \"::\";\
 184              if ((prop & $8000) == 0) prop = (prop & $3f00)/$100;\
 185              else\
 186              {   prop = (prop & $7f00)/$100;\
 187                  i = cla.3;\
 188                  while ((i-->0 ~= 0) && (prop>0))\
 189                  {   i = i + i->2 + 3;\
 190                      prop--;\
 191                  }\
 192                  prop = (i-->0) & $7fff;\
 193              }\
 194          }",
 195         "p = #identifiers_table;\
 196          size = p-->0;\
 197          if (prop<=0 || prop>=size || p-->prop==0)\
 198              print \"<number \", prop, \">\";\
 199          else print (string) p-->prop;\
 200          ]", "", "", "", ""
 201     },
 202
 203     /*  The remaining routines make up the run-time half of the object
 204         orientation system, and need never be present for Inform 5 programs. */
 205
 206     {
 207         /*  WV__Pr:  write a value to the property for the given
 208                      object having the given identifier                      */
 209
 210         "WV__Pr",
 211         "obj identifier value x;\
 212          x = obj..&identifier;\
 213          if (x==0) { RT__Err(\"write to\", obj, identifier); return; }\
 214          #ifdef INFIX;\
 215          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,value);\
 216          #ifnot; #ifdef DEBUG;\
 217          if (debug_flag & 15) RT__TrPS(obj,identifier,value);\
 218          #endif; #endif;\
 219          x-->0 = value;\
 220          ]", "", "", "", "", ""
 221     },
 222     {
 223         /*  RV__Pr:  read a value from the property for the given
 224                      object having the given identifier                      */
 225
 226         "RV__Pr",
 227         "obj identifier x;\
 228          x = obj..&identifier;\
 229          if (x==0)\
 230          {   if (identifier >= 1 && identifier < 64 && obj.#identifier <= 2)\
 231                  return obj.identifier;\
 232              RT__Err(\"read\", obj, identifier); return; }\
 233          if (obj..#identifier > 2) RT__Err(\"read\", obj, identifier, 2);\
 234          return x-->0;\
 235          ]", "", "", "", "", ""
 236     },
 237     {   /*  CA__Pr:  call, that is, print-or-run-or-read, a property:
 238                      this exactly implements obj..prop(...).  Note that
 239                      classes (members of Class) have 5 built-in properties
 240                      inherited from Class: create, recreate, destroy,
 241                      remaining and copy.  Implementing these here prevents
 242                      the need for a full metaclass inheritance scheme.      */
 243
 244         "CA__Pr",
 245         "obj id a b c d e f x y z s s2 n m;\
 246          if (obj < 1 || obj > #largest_object-255)\
 247          {   switch(Z__Region(obj))\
 248              { 2: if (id == call)\
 249                    { s = sender; sender = self; self = obj;\
 250                      #ifdef action;sw__var=action;#endif;\
 251                      x = indirect(obj, a, b, c, d, e, f);\
 252                      self = sender; sender = s; return x; }\
 253                    jump Call__Error;",
 254               "3: if (id == print) { @print_paddr obj; rtrue; }\
 255                    if (id == print_to_array)\
 256                    { @output_stream 3 a; @print_paddr obj; @output_stream -3;\
 257                      return a-->0; }\
 258                    jump Call__Error;\
 259              }\
 260              jump Call__Error;\
 261          }\
 262          @check_arg_count 3 ?~A__x;y++;@check_arg_count 4 ?~A__x;y++;\
 263          @check_arg_count 5 ?~A__x;y++;@check_arg_count 6 ?~A__x;y++;\
 264          @check_arg_count 7 ?~A__x;y++;@check_arg_count 8 ?~A__x;y++;.A__x;",
 265         "#ifdef INFIX;if (obj has infix__watching) n=1;#endif;\
 266          #ifdef DEBUG;if (debug_flag & 1 ~= 0) n=1;#endif;\
 267          if (n==1) {\
 268            #ifdef DEBUG;n=debug_flag & 1; debug_flag=debug_flag-n;#endif;\
 269            print \"[ ~\", (name) obj, \"~.\", (property) id, \"(\";\
 270      switch(y) { 1: print a; 2: print a,\",\",b; 3: print a,\",\",b,\",\",c;\
 271      4: print a,\",\",b,\",\",c,\",\",d;\
 272      5: print a,\",\",b,\",\",c,\",\",d,\",\",e;\
 273      6: print a,\",\",b,\",\",c,\",\",d,\",\",e,\",\",f; }\
 274            print \") ]^\";\
 275            #ifdef DEBUG;debug_flag = debug_flag + n;#endif;\
 276            }",
 277         "if (id > 0 && id < 64)\
 278          { x = obj.&id; if (x==0) { x=$000a-->0 + 2*(id-1); n=2; }\
 279          else n = obj.#id; }\
 280          else\
 281          { if (id>=64 && id<69 && obj in Class)\
 282              return Cl__Ms(obj,id,y,a,b,c,d);\
 283            x = obj..&id;\
 284            if (x == 0) { .Call__Error;\
 285              RT__Err(\"send message\", obj, id); return; }\
 286            n = 0->(x-1);\
 287            if (id&$C000==$4000)\
 288              switch (n&$C0) { 0: n=1; $40: n=2; $80: n=n&$3F; }\
 289          }",
 290         "for (:2*m<n:m++)\
 291          {  if (x-->m==$ffff) rfalse;\
 292             switch(Z__Region(x-->m))\
 293             { 2: s = sender; sender = self; self = obj; s2 = sw__var;\
 294                #ifdef LibSerial;\
 295                if (id==life) sw__var=reason_code; else sw__var=action;\
 296                #endif;\
 297      switch(y) { 0: z = indirect(x-->m); 1: z = indirect(x-->m, a);\
 298      2: z = indirect(x-->m, a, b); 3: z = indirect(x-->m, a, b, c);",
 299     "4: z = indirect(x-->m, a, b, c, d); 5:z = indirect(x-->m, a, b, c, d, e);\
 300      6: z = indirect(x-->m, a, b, c, d, e, f); }\
 301                  self = sender; sender = s; sw__var = s2;\
 302                  if (z ~= 0) return z;\
 303               3: print_ret (string) x-->m;\
 304         default: return x-->m;\
 305             }\
 306          }\
 307          rfalse;\
 308          ]"
 309     },
 310     {
 311         /*  IB__Pr:  ++(individual property)                                 */
 312
 313         "IB__Pr",
 314         "obj identifier x;\
 315          x = obj..&identifier;\
 316          if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
 317          #ifdef INFIX;\
 318          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)+1);\
 319          #ifnot; #ifdef DEBUG;\
 320          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
 321          #endif; #endif;\
 322          return ++(x-->0);\
 323          ]", "", "", "", "", ""
 324     },
 325     {
 326         /*  IA__Pr:  (individual property)++                                 */
 327
 328         "IA__Pr",
 329         "obj identifier x;\
 330          x = obj..&identifier;\
 331          if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
 332          #ifdef INFIX;\
 333          if (obj has infix__watching || (debug_flag & 15))\
 334          RT__TrPS(obj,identifier,(x-->0)+1);\
 335          #ifnot; #ifdef DEBUG;\
 336          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
 337          #endif; #endif;\
 338          return (x-->0)++;\
 339          ]", "", "", "", "", ""
 340     },
 341     {
 342         /*  DB__Pr:  --(individual property)                                 */
 343
 344         "DB__Pr",
 345         "obj identifier x;\
 346          x = obj..&identifier;\
 347          if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
 348          #ifdef INFIX;\
 349          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
 350          #ifnot; #ifdef DEBUG;\
 351          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
 352          #endif; #endif;\
 353          return --(x-->0);\
 354          ]", "", "", "", "", ""
 355     },
 356     {
 357         /*  DA__Pr:  (individual property)--                                 */
 358
 359         "DA__Pr",
 360         "obj identifier x;\
 361          x = obj..&identifier;\
 362          if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
 363          #ifdef INFIX;\
 364          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
 365          #ifnot; #ifdef DEBUG;\
 366          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
 367          #endif; #endif;\
 368          return (x-->0)--;\
 369          ]", "", "", "", "", ""
 370     },
 371     {
 372         /*  RA__Pr:  read the address of a property value for a given object,
 373                      returning 0 if it doesn't provide this individual
 374                      property                                                */
 375
 376         "RA__Pr",
 377         "obj identifier i otherid cla;\
 378          if (obj==0) rfalse;\
 379          if (identifier<64 && identifier>0) return obj.&identifier;\
 380          if (identifier & $8000 ~= 0)\
 381          {   cla = #classes_table-->(identifier & $ff);\
 382              if (cla.&3 == 0) rfalse;\
 383              if (~~(obj ofclass cla)) rfalse;\
 384              identifier = (identifier & $7f00) / $100;\
 385              i = cla.3;\
 386              while (identifier>0)\
 387              {   identifier--;\
 388                  i = i + i->2 + 3;\
 389              }\
 390              return i+3;\
 391          }",
 392         "if (identifier & $4000 ~= 0)\
 393          {   cla = #classes_table-->(identifier & $ff);\
 394              identifier = (identifier & $3f00) / $100;\
 395              if (~~(obj ofclass cla)) rfalse; i=0-->5;\
 396              if (cla == 2) return i+2*identifier-2;\
 397              i = 0-->((i+124+cla*14)/2);\
 398              i = CP__Tab(i + 2*(0->i) + 1, -1)+6;\
 399              return CP__Tab(i, identifier);\
 400          }\
 401          if (obj.&3 == 0) rfalse;\
 402          if (obj in 1)\
 403          {   if (identifier<64 || identifier>=72) rfalse;\
 404          }",
 405         "if (self == obj)\
 406              otherid = identifier | $8000;\
 407          i = obj.3;\
 408          while (i-->0 ~= 0)\
 409          {   if (i-->0 == identifier or otherid)\
 410                  return i+3;\
 411              i = i + i->2 + 3;\
 412          }\
 413          rfalse;\
 414          ]", "", "", ""
 415     },
 416     {
 417         /*  RL__Pr:  read the property length of an individual property value,
 418                      returning 0 if it isn't provided by the given object    */
 419
 420         "RL__Pr",
 421         "obj identifier x;\
 422          if (identifier<64 && identifier>0) return obj.#identifier;\
 423          x = obj..&identifier;\
 424          if (x==0) rfalse;\
 425          if (identifier&$C000==$4000)\
 426              switch (((x-1)->0)&$C0)\
 427              {  0: return 1;  $40: return 2;  $80: return ((x-1)->0)&$3F; }\
 428          return (x-1)->0;\
 429          ]", "", "", "", "", ""
 430     },
 431     {
 432         /*  RA__Sc:  implement the "superclass" (::) operator,
 433                      returning an identifier                                 */
 434
 435         "RA__Sc",
 436         "cla identifier otherid i j k;\
 437          if (cla notin 1 && cla > 4)\
 438          {   RT__Err(\"be a '::' superclass\", cla, -1); rfalse; }\
 439          if (self ofclass cla) otherid = identifier | $8000;\
 440          for (j=0: #classes_table-->j ~= 0: j++)\
 441          {   if (cla==#classes_table-->j)\
 442              {   if (identifier < 64) return $4000 + identifier*$100 + j;\
 443                  if (cla.&3 == 0) break;\
 444                  i = cla.3;",
 445                 "while (i-->0 ~= 0)\
 446                  {   if (i-->0 == identifier or otherid)\
 447                          return $8000 + k*$100 + j;\
 448                      i = i + i->2 + 3;\
 449                      k++;\
 450                  }\
 451                  break;\
 452              }\
 453          }\
 454          RT__Err(\"make use of\", cla, identifier);\
 455          rfalse;\
 456          ]", "", "", "", ""
 457     },
 458     {
 459         /*  OP__Pr:  test whether or not given object provides individual
 460                      property with the given identifier code                 */
 461
 462         "OP__Pr",
 463         "obj identifier;\
 464          if (obj<1 || obj > (#largest_object-255))\
 465          {   if (identifier ~= print or print_to_array or call) rfalse;\
 466              switch(Z__Region(obj))\
 467              {   2: if (identifier == call) rtrue;\
 468                  3: if (identifier == print or print_to_array) rtrue;\
 469              }\
 470              rfalse;\
 471          }",
 472         "if (identifier<64)\
 473          {   if (obj.&identifier ~= 0) rtrue;\
 474              rfalse;\
 475          }\
 476          if (obj..&identifier ~= 0) rtrue;\
 477          if (identifier<72 && obj in 1) rtrue;\
 478          rfalse;\
 479          ]", "", "", "", ""
 480     },
 481     {
 482         /*  OC__Cl:  test whether or not given object is of the given class  */
 483
 484         "OC__Cl",
 485         "obj cla j a n;\
 486          if (obj<1 || obj > (#largest_object-255))\
 487          {   if (cla ~= 3 or 4) rfalse;\
 488              if (Z__Region(obj) == cla-1) rtrue;\
 489              rfalse;\
 490          }\
 491          if (cla == 1) {\
 492              if (obj<=4) rtrue;\
 493              if (obj in 1) rtrue;\
 494              rfalse;\
 495          } else if (cla == 2) {\
 496              if (obj<=4) rfalse;\
 497              if (obj in 1) rfalse;\
 498              rtrue;\
 499          } else if (cla == 3 or 4) {\
 500              rfalse;\
 501          }",
 502         "if (cla notin 1) { RT__Err(\"apply 'ofclass' for\", cla, -1);rfalse;}\
 503          @get_prop_addr obj 2 -> a;\
 504          if (a==0) rfalse;\
 505          @get_prop_len a -> n;\
 506          for (j=0: j<n/2: j++)\
 507          {   if (a-->j == cla) rtrue;\
 508          }\
 509          rfalse;\
 510          ]", "", "", "", ""
 511     },
 512     {   /*  Copy__Primitive:  routine to "deep copy" objects                 */
 513
 514         "Copy__Primitive",
 515         "o1 o2 a1 a2 n m l size identifier;\
 516          for (n=0:n<48:n++)\
 517          {   if (o2 has n) give o1 n;\
 518              else give o1 ~n;\
 519          }\
 520          for (n=1:n<64:n++) if (n~=2 or 3)\
 521          {   a1 = o1.&n; a2 = o2.&n; size = o1.#n;\
 522              if (a1~=0 && a2~=0 && size==o2.#n)\
 523              {   for (m=0:m<size:m++) a1->m=a2->m;\
 524              }\
 525          }",
 526         "if (o1.&3 == 0 || o2.&3 == 0) return;\
 527          for (n=o2.3: n-->0 ~= 0: n = n + size + 3)\
 528          {   identifier = n-->0;\
 529              size = n->2;\
 530              for (m=o1.3: m-->0 ~= 0: m = m + m->2 + 3)\
 531                  if ((identifier & $7fff == (m-->0) & $7fff) && size==m->2)\
 532                      for (l=3: l<size+3: l++) m->l = n->l;\
 533          }\
 534          ]", "", "", "", ""
 535     },
 536     {   /*  RT__Err:  for run-time errors occurring in the above: e.g.,
 537                       an attempt to write to a non-existent individual
 538                       property                                               */
 539
 540         "RT__Err",
 541         "crime obj id size p q;\
 542          print \"^[** Programming error: \";\
 543          if (crime<0) jump RErr;\
 544          if (crime==1) { print \"class \"; @print_obj obj;\
 545          \": 'create' can have 0 to 3 parameters only **]\";}\
 546          if (crime == 32) \"objectloop broken because the object \",\
 547          (name) obj, \" was moved while the loop passed through it **]\";\
 548          if (crime == 33) \"tried to print (char) \", obj,\
 549          \", which is not a valid ZSCII character code for output **]\";\
 550          if (crime == 34) \"tried to print (address) on something not the \",\
 551          \"byte address of a string **]\";\
 552          if (crime == 35) \"tried to print (string) on something not a \",\
 553          \"string **]\";\
 554          if (crime == 36) \"tried to print (object) on something not an \",\
 555          \"object or class **]\";",
 556         "if (crime < 32) { print \"tried to \";\
 557          if (crime >= 28) { if (crime==28 or 29) print \"read from \";\
 558          else print \"write to \";\
 559          if (crime==29 or 31) print \"-\"; print \"->\", obj,\
 560          \" in the\"; switch(size&7){0,1:q=0; 2:print \" string\";\
 561          q=1; 3:print \" table\";q=1; 4:print \" buffer\";q=WORDSIZE;} \
 562          if(size&16) print\" (->)\"; if(size&8) print\" (-->)\";\
 563          \" array ~\", (string) #array_names_offset-->p,\
 564          \"~, which has entries \", q, \" up to \",id,\" **]\"; }\
 565          if (crime >= 24 && crime <=27) { if (crime<=25) print \"read\";\
 566          else print \"write\"; print \" outside memory using \";\
 567          switch(crime) { 24,26:\"-> **]\"; 25,27:\"--> **]\"; } }\
 568          if (crime < 4) print \"test \"; else\
 569          if (crime < 12 || crime > 20) print \"find the \"; else\
 570          if (crime < 14) print \"use \";\
 571          if (crime==20) \"divide by zero **]\"; print \"~\";\
 572          switch(crime) {\
 573          2: print \"in~ or ~notin\"; 3: print \"has~ or ~hasnt\";\
 574          4: print \"parent\"; 5: print \"eldest\"; 6: print \"child\";\
 575          7: print \"younger\"; 8: print \"sibling\"; 9: print \"children\";\
 576          10: print \"youngest\"; 11: print \"elder\";\
 577          12: print \"objectloop\"; 13: print \"}~ at end of ~objectloop\";\
 578          14: \"give~ an attribute to \", (name) obj, \" **]\";\
 579          15: \"remove~ \", (name) obj, \" **]\";",
 580         "16,17,18: print \"move~ \", (name) obj, \" to \", (name) id;\
 581          if (crime==18) { print \", which would make a loop: \",(name) obj;\
 582          p=id; if (p==obj) p=obj;\
 583          else do { print \" in \", (name) p; p=parent(p);} until (p==obj);\
 584          \" in \", (name) p, \" **]\"; }\
 585          \" **]\"; 19: \"give~ or test ~has~ or ~hasnt~ with a non-attribute"\
 586         " on the object \",(name) obj,\" **]\";\
 587          21: print \".&\"; 22: print \".#\"; 23: print \".\"; }\
 588          \"~ of \", (name) obj, \" **]\"; }",
 589         ".RErr; if (obj>=0 && obj<=(#largest_object-255)) {\
 590          if (obj && obj in Class) print \"class \";\
 591          if (obj) @print_obj obj;else print \"nothing\";print\" \";}\
 592          print \"(object number \", obj, \") \";\
 593          if (id<0) print \"is not of class \", (name) -id;",
 594         "else if (size) print \"has a property \", (property) id,\
 595          \", but it is longer than 2 bytes so you cannot use ~.~\";\
 596          else\
 597          {   print \" has no property \", (property) id;\
 598              p = #identifiers_table;\
 599              size = p-->0;\
 600              if (id<0 || id>=size)\
 601                  print \" (and nor has any other object)\";\
 602          }\
 603          print \" to \", (string) crime, \" **]^\";\
 604          ]", ""
 605     },
 606     {   /*  Z__Region:  Determines whether a value is:
 607                         1  an object number
 608                         2  a code address
 609                         3  a string address
 610                         0  none of the above                                 */
 611
 612         "Z__Region",
 613         "addr top;\
 614          if (addr==0 or -1) rfalse;\
 615          top = addr;\
 616          #IfV5; #iftrue (#version_number == 6) || (#version_number == 7);\
 617          @log_shift addr $FFFF -> top; #Endif; #Endif;\
 618          if (Unsigned__Compare(top, $001A-->0) >= 0) rfalse;\
 619          if (addr>=1 && addr<=(#largest_object-255)) rtrue;\
 620          #iftrue #oddeven_packing;\
 621          @test addr 1 ?~NotString;\
 622          if (Unsigned__Compare(addr, #strings_offset)<0) rfalse;\
 623          return 3;\
 624          .NotString;\
 625          if (Unsigned__Compare(addr, #code_offset)<0) rfalse;\
 626          return 2;\
 627          #ifnot;\
 628          if (Unsigned__Compare(addr, #strings_offset)>=0) return 3;\
 629          if (Unsigned__Compare(addr, #code_offset)>=0) return 2;\
 630          rfalse;\
 631          #endif;\
 632          ]", "", "", "", "", ""
 633     },
 634     {   /*  Unsigned__Compare:  returns 1 if x>y, 0 if x=y, -1 if x<y        */
 635
 636         "Unsigned__Compare",
 637         "x y u v;\
 638          if (x==y) return 0;\
 639          if (x<0 && y>=0) return 1;\
 640          if (x>=0 && y<0) return -1;\
 641          u = x&$7fff; v= y&$7fff;\
 642          if (u>v) return 1;\
 643          return -1;\
 644          ]", "", "", "", "", ""
 645     },
 646     {   /*  Meta__class:  returns the metaclass of an object                 */
 647
 648         "Meta__class",
 649         "obj;\
 650          switch(Z__Region(obj))\
 651          {   2: return Routine;\
 652              3: return String;\
 653              1: if (obj in 1 || obj <= 4) return Class;\
 654                 return Object;\
 655          }\
 656          rfalse;\
 657          ]", "", "", "", "", ""
 658     },
 659     {   /*  CP__Tab:  searches a common property table for the given
 660                       identifier, thus imitating the get_prop_addr opcode.
 661                       Returns 0 if not provided, except:
 662                       if the identifier supplied is -1, then returns
 663                       the address of the first byte after the table.         */
 664
 665         "CP__Tab",
 666         "x id n l;\
 667          while ((n=0->x) ~= 0)\
 668          {   if (n & $80) { x++; l = (0->x) & $3f; }\
 669              else { if (n & $40) l=2; else l=1; }\
 670              x++;\
 671              if ((n & $3f) == id) return x;\
 672              x = x + l;\
 673          }\
 674          if (id<0) return x+1; rfalse; ]", "", "", "", "", ""
 675     },
 676     {   /*  Cl__Ms:   the five message-receiving properties of Classes       */
 677
 678         "Cl__Ms",
 679         "obj id y a b c d x;\
 680          switch(id)\
 681          {   create:\
 682                  if (children(obj)<=1) rfalse; x=child(obj);\
 683                  remove x; if (x provides create) { if (y==0) x..create();\
 684                  if (y==1) x..create(a); if (y==2) x..create(a,b);\
 685                  if (y>3) RT__Err(1,obj); if (y>=3) x..create(a,b,c);}\
 686                  return x;\
 687              recreate:\
 688                  if (~~(a ofclass obj))\
 689                  { RT__Err(\"recreate\", a, -obj); rfalse; }\
 690                  Copy__Primitive(a, child(obj));\
 691                  if (a provides create) { if (y==1) a..create();\
 692                  if (y==2) a..create(b); if (y==3) a..create(b,c);\
 693                  if (y>4) RT__Err(1,obj); if (y>=4) a..create(b,c,d);\
 694                  } rfalse;",
 695             "destroy:\
 696                  if (~~(a ofclass obj))\
 697                  { RT__Err(\"destroy\", a, -obj); rfalse; }\
 698                  if (a provides destroy) a..destroy();\
 699                  Copy__Primitive(a, child(obj));\
 700                  move a to obj; rfalse;\
 701              remaining:\
 702                  return children(obj)-1;",
 703             "copy:\
 704                  if (~~(a ofclass obj))\
 705                  { RT__Err(\"copy\", a, -obj); rfalse; }\
 706                  if (~~(b ofclass obj))\
 707                  { RT__Err(\"copy\", b, -obj); rfalse; }\
 708                  Copy__Primitive(a, b); rfalse;\
 709          }\
 710          ]", "", "", ""
 711     },
 712     {   /*  RT__ChT:  check at run-time that a proposed object move is legal
 713                       cause error and do nothing if not; otherwise move */
 714
 715         "RT__ChT",
 716         "obj1 obj2 x;\
 717          if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
 718              return RT__Err(16,obj1,obj2);\
 719          if (obj2<5 || obj2>(#largest_object-255) || obj2 in 1)\
 720              return RT__Err(17,obj1,obj2);",
 721         "x=obj2; while (x~=0) { if (x==obj1) return RT__Err(18,obj1,obj2); \
 722          x=parent(x); }\
 723          #ifdef INFIX;\
 724          if (obj1 has infix__watching\
 725              || obj2 has infix__watching || (debug_flag & 15))\
 726          print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
 727          #ifnot; #ifdef DEBUG;\
 728          if (debug_flag & 15)\
 729          print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
 730          #endif; #endif;\
 731          @insert_obj obj1 obj2; ]", "", "", "", ""
 732     },
 733     {   /*  RT__ChR:  check at run-time that a proposed object remove is legal
 734                       cause error and do nothing if not; otherwise remove */
 735
 736         "RT__ChR",
 737         "obj1;\
 738          if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
 739              return RT__Err(15,obj1);",
 740         "#ifdef INFIX;\
 741          if (obj1 has infix__watching || (debug_flag & 15))\
 742          print \"[Removing \", (name) obj1, \"]^\";\
 743          #ifnot; #ifdef DEBUG;\
 744          if (debug_flag & 15)\
 745          print \"[Removing \", (name) obj1, \"]^\";\
 746          #endif; #endif;\
 747          @remove_obj obj1; ]", "", "", "", ""
 748     },
 749     {   /*  RT__ChG:  check at run-time that a proposed attr give is legal
 750                       cause error and do nothing if not; otherwise give */
 751
 752         "RT__ChG",
 753         "obj1 a;\
 754          if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
 755          return RT__Err(14,obj1); if (a<0 || a>=48) return RT__Err(19,obj1);\
 756          if (obj1 has a) return;",
 757         "#ifdef INFIX;\
 758          if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
 759          print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
 760          #ifnot; #ifdef DEBUG;\
 761          if (a ~= workflag && debug_flag & 15)\
 762          print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
 763          #endif; #endif;\
 764          @set_attr obj1 a; ]", "", "", "", ""
 765     },
 766     {   /*  RT__ChGt:  check at run-time that a proposed attr give ~ is legal
 767                       cause error and do nothing if not; otherwise give */
 768
 769         "RT__ChGt",
 770         "obj1 a;\
 771          if (obj1<5 || obj1>(#largest_object-255) || obj1 in 1)\
 772          return RT__Err(14,obj1); if (a<0 || a>=48) return RT__Err(19,obj1);\
 773          if (obj1 hasnt a) return;",
 774         "#ifdef INFIX;\
 775          if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
 776          print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
 777          #ifnot; #ifdef DEBUG;\
 778          if (a ~= workflag && debug_flag & 15)\
 779          print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
 780          #endif; #endif;\
 781          @clear_attr obj1 a; ]", "", "", "", ""
 782     },
 783     {   /*  RT__ChPS:  check at run-time that a proposed property set is legal
 784                       cause error and do nothing if not; otherwise make it */
 785
 786         "RT__ChPS",
 787         "obj prop val size;\
 788          if (obj<5 || obj>(#largest_object-255) || obj in 1 || obj.&prop==0 || (size=obj.#prop)>2 )\
 789          return RT__Err(\"set\", obj, prop, size);\
 790          @put_prop obj prop val;",
 791         "#ifdef INFIX;\
 792          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,prop,val);\
 793          #ifnot; #ifdef DEBUG;\
 794          if (debug_flag & 15) RT__TrPS(obj,prop,val);\
 795          #endif; #endif;\
 796          return val; ]", "", "", "", ""
 797     },
 798     {   /*  RT__ChPR:  check at run-time that a proposed property read is legal
 799                       cause error and return 0 if not; otherwise read it */
 800
 801         "RT__ChPR",
 802         "obj prop val size;\
 803          if (obj<5 || obj>(#largest_object-255) || (size=obj.#prop)>2)\
 804            {RT__Err(\"read\", obj, prop, size); obj=2;}\
 805          @get_prop obj prop -> val;",
 806         "return val; ]", "", "", "", ""
 807     },
 808     {   /*  RT__TrPS:  trace property settings  */
 809
 810         "RT__TrPS",
 811         "obj prop val;\
 812          print \"[Setting \",(name) obj,\".\",(property) prop,\
 813          \" to \",val,\"]^\"; ]",
 814         "", "", "", "", ""
 815     },
 816     {   /*  RT__ChLDB:  check at run-time that it's safe to load a byte
 817                         and return the byte */
 818
 819         "RT__ChLDB",
 820         "base offset a val;\
 821          a=base+offset;if (Unsigned__Compare(a,#readable_memory_offset)>=0)\
 822          return RT__Err(24);",
 823         "@loadb base offset -> val;return val; ]", "", "", "", ""
 824     },
 825     {   /*  RT__ChLDW:  check at run-time that it's safe to load a word
 826                         and return the word */
 827
 828         "RT__ChLDW",
 829         "base offset a val;\
 830          a=base+2*offset;if (Unsigned__Compare(a,#readable_memory_offset)>=0)\
 831          return RT__Err(25);",
 832         "@loadw base offset -> val;return val; ]", "", "", "", ""
 833     },
 834     {   /*  RT__ChSTB:  check at run-time that it's safe to store a byte
 835                         and store it */
 836
 837         "RT__ChSTB",
 838         "base offset val a f;\
 839          a=base+offset;\
 840          if (Unsigned__Compare(a,#array__start)>=0\
 841              && Unsigned__Compare(a,#array__end)<0) f=1; else\
 842          if (Unsigned__Compare(a,#cpv__start)>=0\
 843              && Unsigned__Compare(a,#cpv__end)<0) f=1; else\
 844          if (Unsigned__Compare(a,#ipv__start)>=0\
 845              && Unsigned__Compare(a,#ipv__end)<0) f=1; else\
 846          if (a==$0011) f=1;\
 847          if (f==0) return RT__Err(26);",
 848         "@storeb base offset val; ]", "", "", "", ""
 849     },
 850     {   /*  RT__ChSTW:  check at run-time that it's safe to store a word
 851                         and store it */
 852
 853         "RT__ChSTW",
 854         "base offset val a f;\
 855          a=base+2*offset;\
 856          if (Unsigned__Compare(a,#array__start)>=0\
 857              && Unsigned__Compare(a,#array__end)<0) f=1; else\
 858          if (Unsigned__Compare(a,#cpv__start)>=0\
 859              && Unsigned__Compare(a,#cpv__end)<0) f=1; else\
 860          if (Unsigned__Compare(a,#ipv__start)>=0\
 861              && Unsigned__Compare(a,#ipv__end)<0) f=1; else\
 862          if (a==$0010) f=1;\
 863          if (f==0) return RT__Err(27);",
 864         "@storew base offset val; ]", "", "", "", ""
 865     },
 866     {   /*  RT__ChPrintC:  check at run-time that it's safe to print (char)
 867                         and do so */
 868
 869         "RT__ChPrintC",
 870         "c fl;\
 871          if (c==0 or 9 or 11 or 13) fl=1;\
 872          if (c>=32 && c<=126) fl=1; if (c>=155 && c<=251) fl=1;\
 873          if (fl==0) return RT__Err(33,c);",
 874         "@print_char c; ]", "", "", "", ""
 875     },
 876     {   /*  RT__ChPrintA:  check at run-time that it's safe to print (address)
 877                         and do so */
 878
 879         "RT__ChPrintA",
 880         "a;\
 881          if (Unsigned__Compare(a, #readable_memory_offset)>=0)\
 882          return RT__Err(34);",
 883         "@print_addr a; ]", "", "", "", ""
 884     },
 885     {   /*  RT__ChPrintS:  check at run-time that it's safe to print (string)
 886                         and do so */
 887
 888         "RT__ChPrintS",
 889         "a;\
 890          if (Z__Region(a)~=3) return RT__Err(35);",
 891         "@print_paddr a; ]", "", "", "", ""
 892     },
 893     {   /*  RT__ChPrintO:  check at run-time that it's safe to print (object)
 894                         and do so */
 895
 896         "RT__ChPrintO",
 897         "a;\
 898          if (Z__Region(a)~=1) return RT__Err(36);",
 899         "@print_obj a; ]", "", "", "", ""
 900     }
 901 };
 902
 903 static VeneerRoutine VRs_g[VENEER_ROUTINES] =
 904 {
 905     {
 906         /*  Box__Routine: Display the given array of text as a box quote.
 907             This is a very simple implementation; the library should provide
 908             a fancier version.
 909         */
 910         "Box__Routine",
 911         "maxwid arr ix;\
 912            maxwid = 0;\
 913            glk($0086, 7);\
 914            for (ix=0 : ix<arr-->0 : ix++) {\
 915              print (string) arr-->(ix+1);\
 916              new_line;\
 917            }\
 918            glk($0086, 0);\
 919          ]", "", "", "", "", ""
 920     },
 921
 922     /*  This batch of routines is expected to be defined (rather better) by
 923         the Inform library: these minimal forms here are provided to prevent
 924         tiny non-library-using programs from failing to compile when certain
 925         legal syntaxes (such as <<Action a b>>;) are used.                   */
 926
 927     {   "R_Process",
 928         "a b c d; print \"Action <\", a, \" \", b, \" \", c;\
 929          if (d) print \", \", d; print \">^\";\
 930          ]", "", "", "", "", ""
 931     },
 932     {   "DefArt",
 933         "obj; print \"the \", obj; ]", "", "", "", "", ""
 934     },
 935     {   "InDefArt",
 936         "obj; print \"a \", obj; ]", "", "", "", "", ""
 937     },
 938     {   "CDefArt",
 939         "obj; print \"The \", obj; ]", "", "", "", "", ""
 940     },
 941     {   "CInDefArt",
 942         "obj; print \"A \", obj; ]", "", "", "", "", ""
 943     },
 944     {   "PrintShortName",
 945         "obj q; switch(metaclass(obj))\
 946          {   0: print \"nothing\";\
 947              Object: q = obj-->GOBJFIELD_NAME; @streamstr q;\
 948              Class: print \"class \"; q = obj-->GOBJFIELD_NAME; @streamstr q;\
 949              Routine: print \"(routine at \", obj, \")\";\
 950              String: print \"(string at \", obj, \")\";\
 951          } ]", "", "", "", "", ""
 952     },
 953     {   "EnglishNumber",
 954         "obj; print obj; ]", "", "", "", "", ""
 955     },
 956     {
 957         /*  Print__PName: Print the name of a property.
 958         */
 959         "Print__PName",
 960         "prop ptab cla maxcom minind maxind str;\
 961            if (prop & $FFFF0000) {\
 962              cla = #classes_table-->(prop & $FFFF);\
 963              print (name) cla, \"::\";\
 964              @ushiftr prop 16 prop;\
 965            }\
 966            ptab = #identifiers_table;\
 967            maxcom = ptab-->1;\
 968            minind = INDIV_PROP_START;\
 969            maxind = minind + ptab-->3;\
 970            str = 0;\
 971            if (prop >= 0 && prop < maxcom) {\
 972              str = (ptab-->0)-->prop;\
 973            }\
 974            else if (prop >= minind && prop < maxind) {\
 975              str = (ptab-->2)-->(prop-minind);\
 976            }\
 977            if (str)\
 978              print (string) str;\
 979            else\
 980              print \"<number \", prop, \">\";\
 981          ]", "", "", "", "", ""
 982     },
 983
 984     /*  The remaining routines make up the run-time half of the object
 985         orientation system, and need never be present for Inform 5 programs. */
 986
 987     {
 988         /*  WV__Pr: Write a value to the property for the given object.
 989         */
 990         "WV__Pr",
 991         "obj id val addr;\
 992            addr = obj.&id;\
 993            if (addr == 0) {\
 994              RT__Err(\"write\", obj, id);\
 995              return 0;\
 996            }\
 997            addr-->0 = val;\
 998            return 0;\
 999          ]", "", "", "", "", ""
1000     },
1001
1002     {
1003         /*  RV__Pr: Read a value to the property for the given object.
1004         */
1005         "RV__Pr",
1006         "obj id addr;\
1007            addr = obj.&id;\
1008            if (addr == 0) {\
1009              if (id > 0 && id < INDIV_PROP_START) {\
1010                return #cpv__start-->id;\
1011              }\
1012              RT__Err(\"read\", obj, id);\
1013              return 0;\
1014            }\
1015            return addr-->0;\
1016          ]", "", "", "", "", ""
1017     },
1018     {
1019         /*  CA__Pr: Call, that is, print-or-run-or-read, a property:
1020             this exactly implements obj..prop(...).  Note that
1021             classes (members of Class) have 5 built-in properties
1022             inherited from Class: create, recreate, destroy,
1023             remaining and copy.  Implementing these here prevents
1024             the need for a full metaclass inheritance scheme.
1025         */
1026         "CA__Pr",
1027         "_vararg_count obj id zr s s2 z addr len m val;\
1028            @copy sp obj;\
1029            @copy sp id;\
1030            _vararg_count = _vararg_count - 2;\
1031            zr = Z__Region(obj);\
1032            if (zr == 2) {\
1033              if (id == call) {\
1034                s = sender; sender = self; self = obj;\
1035                #ifdef action; sw__var=action; #endif;\
1036                @call obj _vararg_count z;\
1037                self = sender; sender = s;\
1038                return z;\
1039              }\
1040              jump Call__Error;\
1041            }",
1042         "  if (zr == 3) {\
1043              if (id == print) {\
1044                @streamstr obj; rtrue;\
1045              }\
1046              if (id == print_to_array) {\
1047                if (_vararg_count >= 2) {\
1048                  @copy sp m;\
1049                  @copy sp len;\
1050                }\
1051                else {\
1052                  RT__Err(37); rfalse;\
1053                }\
1054                s2 = glk($0048);\
1055                s = glk($0043, m+4, len-4, 1, 0);",
1056         "      if (s) {\
1057                  glk($0047, s);\
1058                  @streamstr obj;\
1059                  glk($0047, s2);\
1060                  @copy $ffffffff sp;\
1061                  @copy s sp;\
1062                  @glk $0044 2 0;\
1063                  @copy sp len;\
1064                  @copy sp 0;\
1065                  m-->0 = len;\
1066                  return len;\
1067                }\
1068                rfalse;\
1069              }\
1070              jump Call__Error;\
1071            }",
1072         "  if (zr ~= 1)\
1073              jump Call__Error;\
1074            #ifdef DEBUG;#ifdef InformLibrary;\
1075            if (debug_flag & 1 ~= 0) {\
1076              debug_flag--;\
1077              print \"[ ~\", (name) obj, \"~.\", (property) id, \"(\";\
1078              @stkcopy _vararg_count;\
1079              for (val=0 : val < _vararg_count : val++) {\
1080                if (val) print \", \";\
1081                @streamnum sp;\
1082              }\
1083              print \") ]^\";\
1084              debug_flag++;\
1085            }\
1086            #endif;#endif;\
1087            if (obj in Class) {\
1088              switch (id) {\
1089                remaining:\
1090                  return Cl__Ms(obj, id);\
1091                copy:\
1092                  @copy sp m;\
1093                  @copy sp val;\
1094                  return Cl__Ms(obj, id, m, val);\
1095                create, destroy, recreate:\
1096                  m = _vararg_count+2;\
1097                  @copy id sp;\
1098                  @copy obj sp;\
1099                  @call Cl__Ms m val;\
1100                  return val;\
1101              }\
1102            }",
1103         "  addr = obj.&id;\
1104            if (addr == 0) {\
1105              if (id > 0 && id < INDIV_PROP_START) {\
1106                addr = #cpv__start + 4*id;\
1107                len = 4;\
1108              }\
1109              else {\
1110                jump Call__Error;\
1111              }\
1112            }\
1113            else {\
1114              len = obj.#id;\
1115            }\
1116            for (m=0 : 4*m<len : m++) {\
1117              val = addr-->m;\
1118              if (val == -1) rfalse;\
1119              switch (Z__Region(val)) {\
1120                2:\
1121                  s = sender; sender = self; self = obj; s2 = sw__var;\
1122                  #ifdef LibSerial;\
1123                  if (id==life) sw__var=reason_code; else sw__var=action;\
1124                  #endif;",
1125         "        @stkcopy _vararg_count;\
1126                  @call val _vararg_count z;\
1127                  self = sender; sender = s; sw__var = s2;\
1128                  if (z ~= 0) return z;\
1129                3:\
1130                  @streamstr val;\
1131                  new_line;\
1132                  rtrue;\
1133                default:\
1134                  return val;\
1135              }\
1136            }\
1137            rfalse;\
1138            .Call__Error;\
1139            RT__Err(\"send message\", obj, id);\
1140            rfalse;\
1141          ]"
1142     },
1143     {
1144         /*  IB__Pr:  ++(individual property)                                 */
1145
1146         "IB__Pr",
1147         "obj identifier x;\
1148          x = obj.&identifier;\
1149          if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
1150          #ifdef INFIX;\
1151          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)+1);\
1152          #ifnot; #ifdef DEBUG;\
1153          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
1154          #endif; #endif;\
1155          return ++(x-->0);\
1156          ]", "", "", "", "", ""
1157     },
1158     {
1159         /*  IA__Pr:  (individual property)++                                 */
1160
1161         "IA__Pr",
1162         "obj identifier x;\
1163          x = obj.&identifier;\
1164          if (x==0) { RT__Err(\"increment\", obj, identifier); return; }\
1165          #ifdef INFIX;\
1166          if (obj has infix__watching || (debug_flag & 15))\
1167          RT__TrPS(obj,identifier,(x-->0)+1);\
1168          #ifnot; #ifdef DEBUG;\
1169          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)+1);\
1170          #endif; #endif;\
1171          return (x-->0)++;\
1172          ]", "", "", "", "", ""
1173     },
1174     {
1175         /*  DB__Pr:  --(individual property)                                 */
1176
1177         "DB__Pr",
1178         "obj identifier x;\
1179          x = obj.&identifier;\
1180          if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
1181          #ifdef INFIX;\
1182          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
1183          #ifnot; #ifdef DEBUG;\
1184          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
1185          #endif; #endif;\
1186          return --(x-->0);\
1187          ]", "", "", "", "", ""
1188     },
1189     {
1190         /*  DA__Pr:  (individual property)--                                 */
1191
1192         "DA__Pr",
1193         "obj identifier x;\
1194          x = obj.&identifier;\
1195          if (x==0) { RT__Err(\"decrement\", obj, identifier); return; }\
1196          #ifdef INFIX;\
1197          if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,identifier,(x-->0)-1);\
1198          #ifnot; #ifdef DEBUG;\
1199          if (debug_flag & 15) RT__TrPS(obj,identifier,(x-->0)-1);\
1200          #endif; #endif;\
1201          return (x-->0)--;\
1202          ]", "", "", "", "", ""
1203     },
1204     {
1205         /*  RA__Pr: Read the property address of a given property value.
1206             Returns zero if it isn't provided by the object. This
1207             understands all the same concerns as RL__Pr().
1208         */
1209         "RA__Pr",
1210         "obj id cla prop ix;\
1211            if (id & $FFFF0000) {\
1212              cla = #classes_table-->(id & $FFFF);\
1213              if (~~(obj ofclass cla)) return 0;\
1214              @ushiftr id 16 id;\
1215              obj = cla;\
1216            }\
1217            prop = CP__Tab(obj, id);\
1218            if (prop==0) return 0;\
1219            if (obj in Class && cla == 0) {\
1220              if (id < INDIV_PROP_START || id >= INDIV_PROP_START+8)\
1221                return 0;\
1222            }\
1223            if (self ~= obj) {\
1224              @aloadbit prop 72 ix;\
1225              if (ix) return 0;\
1226            }\
1227            return prop-->1;\
1228          ]", "", "", "", "", ""
1229     },
1230
1231     {
1232         /*  RL__Pr: Read the property length of a given property value.
1233             Returns zero if it isn't provided by the object. This understands
1234             inherited values (of the form class::prop) as well as simple
1235             property ids and the special metaclass methods. It also knows
1236             that private properties can only be read if (self == obj).
1237         */
1238         "RL__Pr",
1239         "obj id cla prop ix;\
1240            if (id & $FFFF0000) {\
1241              cla = #classes_table-->(id & $FFFF);\
1242              if (~~(obj ofclass cla)) return 0;\
1243              @ushiftr id 16 id;\
1244              obj = cla;\
1245            }\
1246            prop = CP__Tab(obj, id);\
1247            if (prop==0) return 0;\
1248            if (obj in Class && cla == 0) {\
1249              if (id < INDIV_PROP_START || id >= INDIV_PROP_START+8)\
1250                return 0;\
1251            }\
1252            if (self ~= obj) {\
1253              @aloadbit prop 72 ix;\
1254              if (ix) return 0;\
1255            }\
1256            @aloads prop 1 ix;\
1257            return WORDSIZE * ix;\
1258          ]", "", "", "", "", ""
1259     },
1260     {
1261         /*  RA__Sc: Implement the \"superclass\" (::) operator. This
1262             returns an compound property identifier, which is a
1263             32-bit value.
1264         */
1265         "RA__Sc",
1266         "cla id j;\
1267            if ((cla notin Class) && (cla ~= Class or String or Routine or Object)) {\
1268              RT__Err(\"be a '::' superclass\", cla, -1);\
1269              rfalse;\
1270            }\
1271            for (j=0 : #classes_table-->j ~= 0 : j++) {\
1272              if (cla == #classes_table-->j) {\
1273                return (id * $10000 + j);\
1274              }\
1275            }\
1276            RT__Err(\"make use of\", cla, id);\
1277            rfalse;\
1278          ]", "", "", "", "", ""
1279     },
1280
1281     {
1282         /*  OP__Pr: Test whether the given object provides the given property.
1283             This winds up calling RA__Pr().
1284         */
1285         "OP__Pr",
1286         "obj id zr;\
1287            zr = Z__Region(obj);\
1288            if (zr == 3) {\
1289              if (id == print or print_to_array) rtrue;\
1290              rfalse;\
1291            }\
1292            if (zr == 2) {\
1293              if (id == call) rtrue;\
1294              rfalse;\
1295            }\
1296            if (zr ~= 1) rfalse;\
1297            if (id >= INDIV_PROP_START && id < INDIV_PROP_START+8) {\
1298              if (obj in Class) rtrue;\
1299            }\
1300            if (obj.&id ~= 0)\
1301              rtrue;\
1302            rfalse;\
1303          ]", "", "", "", "", ""
1304     },
1305     {
1306         /*  OC__Cl: Test whether the given object is of the given class.
1307             (implements the OfClass operator.)
1308         */
1309         "OC__Cl",
1310         "obj cla zr jx inlist inlistlen;\
1311            zr = Z__Region(obj);\
1312            if (zr == 3) {\
1313              if (cla == String) rtrue;\
1314              rfalse;\
1315            }\
1316            if (zr == 2) {\
1317              if (cla == Routine) rtrue;\
1318              rfalse;\
1319            }\
1320            if (zr ~= 1) rfalse;\
1321            if (cla == Class) {\
1322              if (obj in Class\
1323                || obj == Class or String or Routine or Object)\
1324                rtrue;\
1325              rfalse;\
1326            }\
1327            if (cla == Object) {\
1328              if (obj in Class\
1329                || obj == Class or String or Routine or Object)\
1330                rfalse;\
1331              rtrue;\
1332            }\
1333            if (cla == String or Routine) rfalse;\
1334            if (cla notin Class) {\
1335              RT__Err(\"apply 'ofclass' for\", cla, -1);\
1336              rfalse;\
1337            }\
1338            inlist = obj.&2;\
1339            if (inlist == 0) rfalse;\
1340            inlistlen = (obj.#2) / WORDSIZE;\
1341            for (jx=0 : jx<inlistlen : jx++) {\
1342              if (inlist-->jx == cla) rtrue;\
1343            }\
1344            rfalse;\
1345          ]", "", "", "", "", ""
1346     },
1347
1348     {
1349         /*  Copy__Primitive: Routine to \"deep copy\" objects.
1350         */
1351         "Copy__Primitive",
1352         "o1 o2 p1 p2 pcount i j propid proplen val pa1 pa2;\
1353            for (i=1 : i<=NUM_ATTR_BYTES : i++) {\
1354              o1->i = o2->i;\
1355            }\
1356            p2 = o2-->GOBJFIELD_PROPTAB;\
1357            pcount = p2-->0;\
1358            p2 = p2+4;\
1359            for (i=0 : i<pcount : i++) {\
1360              @aloads p2 0 propid;\
1361              @aloads p2 1 proplen;\
1362              p1 = CP__Tab(o1, propid);\
1363              if (p1) {\
1364                @aloads p1 1 val;\
1365                if (proplen == val) {\
1366                  @aloads p2 4 val;\
1367                  @astores p1 4 val;\
1368                  pa1 = p1-->1;\
1369                  pa2 = p2-->1;\
1370                  for (j=0 : j<proplen : j++)\
1371                    pa1-->j = pa2-->j;\
1372                }\
1373              }\
1374              p2 = p2+10;\
1375            }\
1376          ]", "", "", "", "", ""
1377     },
1378     {   /*  RT__Err:  for run-time errors occurring in the above: e.g.,
1379                       an attempt to write to a non-existent individual
1380                       property                                               */
1381
1382         "RT__Err",
1383         "crime obj id size p q;\
1384          print \"^[** Programming error: \";\
1385          if (crime<0) jump RErr;\
1386          if (crime==1) { print \"class \"; q = obj-->GOBJFIELD_NAME; @streamstr q;\
1387          \": 'create' can have 0 to 3 parameters only **]\";}\
1388          if (crime == 40) \"tried to change printing variable \",\
1389          obj, \"; must be 0 to \", #dynam_string_table-->0-1, \" **]\";\
1390          if (crime == 32) \"objectloop broken because the object \",\
1391          (name) obj, \" was moved while the loop passed through it **]\";\
1392          if (crime == 33) \"tried to print (char) \", obj,\
1393          \", which is not a valid Glk character code for output **]\";\
1394          if (crime == 34) \"tried to print (address) on something not the \",\
1395          \"address of a dict word **]\";\
1396          if (crime == 35) \"tried to print (string) on something not a \",\
1397          \"string **]\";\
1398          if (crime == 36) \"tried to print (object) on something not an \",\
1399          \"object or class **]\";\
1400          if (crime == 37) \"tried to call Glulx print_to_array with only \",\
1401          \"one argument **]\";",
1402         "if (crime < 32) { print \"tried to \";\
1403          if (crime >= 28) { if (crime==28 or 29) print \"read from \";\
1404          else print \"write to \";\
1405          if (crime==29 or 31) print \"-\"; print \"->\", obj,\
1406          \" in the\"; switch(size&7){0,1:q=0; 2:print \" string\";\
1407          q=1; 3:print \" table\";q=1; 4:print \" buffer\";q=WORDSIZE;} \
1408          if(size&16) print\" (->)\"; if(size&8) print\" (-->)\";\
1409          \" array ~\", (string) #array_names_offset-->(p+1),\
1410          \"~, which has entries \", q, \" up to \",id,\" **]\"; }\
1411          if (crime >= 24 && crime <=27) { if (crime<=25) print \"read\";\
1412          else print \"write\"; print \" outside memory using \";\
1413          switch(crime) { 24,26:\"-> **]\"; 25,27:\"--> **]\"; } }\
1414          if (crime < 4) print \"test \"; else\
1415          if (crime < 12 || crime > 20) print \"find the \"; else\
1416          if (crime < 14) print \"use \";\
1417          if (crime==20) \"divide by zero **]\"; print \"~\";\
1418          switch(crime) {\
1419          2: print \"in~ or ~notin\"; 3: print \"has~ or ~hasnt\";\
1420          4: print \"parent\"; 5: print \"eldest\"; 6: print \"child\";\
1421          7: print \"younger\"; 8: print \"sibling\"; 9: print \"children\";\
1422          10: print \"youngest\"; 11: print \"elder\";\
1423          12: print \"objectloop\"; 13: print \"}~ at end of ~objectloop\";\
1424          14: \"give~ an attribute to \", (name) obj, \" **]\";\
1425          15: \"remove~ \", (name) obj, \" **]\";",
1426         "16,17,18: print \"move~ \", (name) obj, \" to \", (name) id;\
1427          if (crime==18) { print \", which would make a loop: \",(name) obj;\
1428          p=id; if (p==obj) p=obj;\
1429          else do { print \" in \", (name) p; p=parent(p);} until (p==obj);\
1430          \" in \", (name) p, \" **]\"; }\
1431          \" **]\"; 19: \"give~ or test ~has~ or ~hasnt~ with a non-attribute"\
1432         " on the object \",(name) obj,\" **]\";\
1433          21: print \".&\"; 22: print \".#\"; 23: print \".\"; }\
1434          \"~ of \", (name) obj, \" **]\"; }",
1435         ".RErr; if (obj==0 || obj->0>=$70 && obj->0<=$7F) {\
1436          if (obj && obj in Class) print \"class \";\
1437          if (obj) print (object) obj;else print \"nothing\";print\" \";}\
1438          print \"(object number \", obj, \") \";\
1439          if (id<0) print \"is not of class \", (name) -id;",
1440         "else\
1441          {   print \" has no property \", (property) id;\
1442              p = #identifiers_table;\
1443              size = INDIV_PROP_START + p-->3;\
1444              if (id<0 || id>=size)\
1445                  print \" (and nor has any other object)\";\
1446          }\
1447          print \" to \", (string) crime, \" **]^\";\
1448          ]", ""
1449     },
1450     {
1451         /*  Z__Region:  Determines whether a value is:
1452             1  an object number
1453             2  a code address
1454             3  a string address
1455             0  none of the above
1456         */
1457         "Z__Region",
1458         "addr tb endmem;\
1459            if (addr<36) rfalse;\
1460            @getmemsize endmem;\
1461            @jgeu addr endmem?outrange;\
1462            tb=addr->0;\
1463            if (tb >= $E0) return 3;\
1464            if (tb >= $C0) return 2;\
1465            if (tb >= $70 && tb <= $7F && addr >= (0-->2)) return 1;\
1466            .outrange;\
1467            rfalse;\
1468          ]", "", "", "", "", ""
1469     },
1470     {   /*  Unsigned__Compare:  returns 1 if x>y, 0 if x=y, -1 if x<y        */
1471
1472         "Unsigned__Compare",
1473         "x y;\
1474          @jleu x y ?lesseq;\
1475          return 1;\
1476          .lesseq;\
1477          @jeq x y ?equal;\
1478          return -1;\
1479          .equal;\
1480          return 0;\
1481          ]", "", "", "", "", ""
1482     },
1483     {   /*  Meta__class:  returns the metaclass of an object                 */
1484
1485         "Meta__class",
1486         "obj;\
1487          switch(Z__Region(obj))\
1488          {   2: return Routine;\
1489              3: return String;\
1490              1: if (obj in Class\
1491                     || obj == Class or String or Routine or Object)\
1492                   return Class;\
1493                 return Object;\
1494          }\
1495          rfalse;\
1496          ]", "", "", "", "", ""
1497     },
1498
1499     {
1500         /*  CP__Tab: Search a property table for the given identifier.
1501             The definition here is a bit different from the Z-code veneer.
1502             This just searches the property table of obj for an entry with
1503             the given identifier. It return the address of the property
1504             entry, or 0 if nothing found. (Remember that the value returned
1505             is not the address of the property *data*; it's the structure
1506             which contains the address/length/flags.)
1507         */
1508         "CP__Tab",
1509         "obj id otab max res;\
1510            if (Z__Region(obj)~=1) {RT__Err(23, obj); rfalse;}\
1511            otab = obj-->GOBJFIELD_PROPTAB;\
1512            if (otab == 0) return 0;\
1513            max = otab-->0;\
1514            otab = otab+4;\
1515            @binarysearch id 2 otab 10 max 0 0 res;\
1516            return res;\
1517          ]", "", "", "", "", ""
1518     },
1519
1520     {
1521         /*  Cl__Ms: Implements the five message-receiving properties of
1522             Classes.
1523         */
1524         "Cl__Ms",
1525         "_vararg_count obj id a b x y;\
1526            @copy sp obj;\
1527            @copy sp id;\
1528            _vararg_count = _vararg_count - 2;\
1529            switch (id) {\
1530              create:\
1531                if (children(obj) <= 1) rfalse;\
1532                x = child(obj);\
1533                remove x;\
1534                if (x provides create) {\
1535                  @copy create sp;\
1536                  @copy x sp;\
1537                  y = _vararg_count + 2;\
1538                  @call CA__Pr y 0;\
1539                }\
1540                return x;\
1541              recreate:\
1542                @copy sp a;\
1543                _vararg_count--;\
1544                if (~~(a ofclass obj)) {\
1545                  RT__Err(\"recreate\", a, -obj);\
1546                  rfalse;\
1547                }\
1548                if (a provides destroy)\
1549                  a.destroy();\
1550                Copy__Primitive(a, child(obj));\
1551                if (a provides create) {\
1552                  @copy create sp;\
1553                  @copy a sp;\
1554                  y = _vararg_count + 2;\
1555                  @call CA__Pr y 0;\
1556                }\
1557                rfalse;\
1558              destroy:\
1559                @copy sp a;\
1560                _vararg_count--;\
1561                if (~~(a ofclass obj)) {\
1562                  RT__Err(\"destroy\", a, -obj);\
1563                  rfalse;\
1564                }\
1565                if (a provides destroy)\
1566                  a.destroy();\
1567                Copy__Primitive(a, child(obj));\
1568                move a to obj;\
1569                rfalse;\
1570              remaining:\
1571                return children(obj)-1;\
1572              copy:\
1573                @copy sp a;\
1574                @copy sp b;\
1575                _vararg_count = _vararg_count - 2;\
1576                if (~~(a ofclass obj)) {\
1577                  RT__Err(\"copy\", a, -obj);\
1578                  rfalse;\
1579                }\
1580                if (~~(b ofclass obj)) {\
1581                  RT__Err(\"copy\", b, -obj);\
1582                  rfalse;\
1583                }\
1584                Copy__Primitive(a, b);\
1585                rfalse;\
1586            }\
1587          ]", "", "", "", "", ""
1588     },
1589     {
1590         /*  RT__ChT:  Check at run-time that a proposed object move is legal.
1591             Cause error and do nothing if not; otherwise move
1592         */
1593         "RT__ChT",
1594         "obj1 obj2 ix;\
1595            if (obj1==0 || Z__Region(obj1)~=1\
1596              || (obj1 == Class or String or Routine or Object) || obj1 in Class)\
1597              return RT__Err(16, obj1, obj2);\
1598            if (obj2==0 || Z__Region(obj2)~=1\
1599              || (obj2 == Class or String or Routine or Object) || obj2 in Class)\
1600              return RT__Err(17, obj1, obj2);\
1601            ix = obj2;\
1602            while (ix ~= 0) {\
1603              if (ix==obj1) return RT__Err(18, obj1, obj2);\
1604              ix = parent(ix);\
1605            }\
1606            #ifdef INFIX;\
1607            if (obj1 has infix__watching\
1608              || obj2 has infix__watching || (debug_flag & 15))\
1609                print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
1610            #ifnot; #ifdef DEBUG;\
1611            if (debug_flag & 15)\
1612              print \"[Moving \", (name) obj1, \" to \", (name) obj2, \"]^\";\
1613            #endif; #endif;\
1614            OB__Move(obj1, obj2);\
1615          ]", "", "", "", "", ""
1616     },
1617     {
1618         /*  RT__ChR:  Check at run-time that a proposed object remove is legal.
1619             Cause error and do nothing if not; otherwise remove
1620         */
1621         "RT__ChR",
1622         "obj1;\
1623            if (obj1==0 || Z__Region(obj1)~=1\
1624              || (obj1 == Class or String or Routine or Object) || obj1 in Class)\
1625              return RT__Err(15, obj1);\
1626            #ifdef INFIX;\
1627            if (obj1 has infix__watching || (debug_flag & 15))\
1628              print \"[Removing \", (name) obj1, \"]^\";\
1629            #ifnot; #ifdef DEBUG;\
1630            if (debug_flag & 15)\
1631              print \"[Removing \", (name) obj1, \"]^\";\
1632            #endif; #endif;\
1633            OB__Remove(obj1);\
1634          ]", "", "", "", "", ""
1635     },
1636     {   /*  RT__ChG:  check at run-time that a proposed attr give is legal
1637                       cause error and do nothing if not; otherwise give */
1638
1639         "RT__ChG",
1640         "obj1 a;\
1641          if (Z__Region(obj1) ~= 1) return RT__Err(14,obj1);\
1642          if (obj1 in Class || obj1 == Class or String or Routine or Object)\
1643            return RT__Err(14,obj1);\
1644          if (a<0 || a>=NUM_ATTR_BYTES*8) return RT__Err(19,obj1);\
1645          if (obj1 has a) return;",
1646         "#ifdef INFIX;\
1647          if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
1648          print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
1649          #ifnot; #ifdef DEBUG;\
1650          if (a ~= workflag && debug_flag & 15)\
1651          print \"[Giving \", (name) obj1, \" \", (DebugAttribute) a, \"]^\";\
1652          #endif; #endif;\
1653          give obj1 a; ]", "", "", "", ""
1654     },
1655     {   /*  RT__ChGt:  check at run-time that a proposed attr give ~ is legal
1656                       cause error and do nothing if not; otherwise give */
1657
1658         "RT__ChGt",
1659         "obj1 a;\
1660          if (Z__Region(obj1) ~= 1) return RT__Err(14,obj1);\
1661          if (obj1 in Class || obj1 == Class or String or Routine or Object)\
1662            return RT__Err(14,obj1);\
1663          if (a<0 || a>=NUM_ATTR_BYTES*8) return RT__Err(19,obj1);\
1664          if (obj1 hasnt a) return;",
1665         "#ifdef INFIX;\
1666          if (a ~= workflag && (obj1 has infix__watching || (debug_flag & 15)))\
1667          print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
1668          #ifnot; #ifdef DEBUG;\
1669          if (a ~= workflag && debug_flag & 15)\
1670          print \"[Giving \",(name) obj1,\" @@126\", (DebugAttribute) a, \"]^\";\
1671          #endif; #endif;\
1672          give obj1 ~a; ]", "", "", "", ""
1673     },
1674     {
1675         /*  RT__ChPS: Check at run-time that a proposed property set is legal.
1676             Cause error and do nothing if not; otherwise make it.
1677         */
1678         "RT__ChPS",
1679         "obj prop val res;\
1680            if (obj==0 || Z__Region(obj)~=1\
1681              || (obj == Class or String or Routine or Object) || obj in Class)\
1682                return RT__Err(\"set\", obj, prop);\
1683            res = WV__Pr(obj, prop, val);\
1684            #ifdef INFIX;\
1685            if (obj has infix__watching || (debug_flag & 15)) RT__TrPS(obj,prop,val);\
1686            #ifnot; #ifdef DEBUG;\
1687            if (debug_flag & 15) RT__TrPS(obj,prop,val);\
1688            #endif; #endif;\
1689            return res;\
1690          ]", "", "", "", "", ""
1691     },
1692     {   /*  RT__ChPR:  check at run-time that a proposed property read is legal.
1693                        cause error and return 0 if not; otherwise read it */
1694         "RT__ChPR",
1695         "obj prop val;\
1696          if (obj==0 or Class or String or Routine or Object || Z_Region(obj)~=1 )\
1697            {RT__Err(\"read\", obj, prop); obj=2;}\
1698          val = RV__Pr(obj, prop);",
1699         "return val; ]", "", "", "", ""
1700     },
1701     {   /*  RT__TrPS:  trace property settings  */
1702
1703         "RT__TrPS",
1704         "obj prop val;\
1705          print \"[Setting \",(name) obj,\".\",(property) prop,\
1706          \" to \",val,\"]^\"; ]",
1707         "", "", "", "", ""
1708     },
1709     {
1710         /*  RT__ChLDB: Check at run-time that it's safe to load a byte
1711             and return the byte.
1712         */
1713         "RT__ChLDB",
1714         "base offset a b val;\
1715            a=base+offset;\
1716            @getmemsize b;\
1717            if (Unsigned__Compare(a, b) >= 0)\
1718              return RT__Err(24);\
1719            @aloadb base offset val;\
1720            return val;\
1721          ]", "", "", "", "", ""
1722     },
1723
1724     {
1725         /*  RT__ChLDW: Check at run-time that it's safe to load a word
1726             and return the word
1727         */
1728         "RT__ChLDW",
1729         "base offset a b val;\
1730            a=base+WORDSIZE*offset;\
1731            @getmemsize b;\
1732            if (Unsigned__Compare(a, b) >= 0)\
1733              return RT__Err(25);\
1734            @aload base offset val;\
1735            return val;\
1736          ]", "", "", "", "", ""
1737     },
1738
1739     {
1740         /*  RT__ChSTB: Check at run-time that it's safe to store a byte
1741             and store it
1742         */
1743         "RT__ChSTB",
1744         "base offset val a b;\
1745            a=base+offset;\
1746            @getmemsize b;\
1747            if (Unsigned__Compare(a, b) >= 0) jump ChSTB_Fail;\
1748            @aload 0 2 b;\
1749            if (Unsigned__Compare(a, b) < 0) jump ChSTB_Fail;\
1750            @astoreb base offset val;\
1751            return;\
1752          .ChSTB_Fail;\
1753            return RT__Err(26);\
1754          ]", "", "", "", "", ""
1755     },
1756
1757     {
1758         /*  RT__ChSTW: Check at run-time that it's safe to store a word
1759             and store it
1760         */
1761         "RT__ChSTW",
1762         "base offset val a b;\
1763            a=base+WORDSIZE*offset;\
1764            @getmemsize b;\
1765            if (Unsigned__Compare(a, b) >= 0) jump ChSTW_Fail;\
1766            @aload 0 2 b;\
1767            if (Unsigned__Compare(a, b) < 0) jump ChSTW_Fail;\
1768            @astore base offset val;\
1769            return;\
1770          .ChSTW_Fail;\
1771            return RT__Err(27);\
1772          ]", "", "", "", "", ""
1773     },
1774
1775     {
1776       /*  RT__ChPrintC: Check at run-time that it's safe to print (char)
1777             and do so.
1778       */
1779         "RT__ChPrintC",
1780         "c;\
1781            if (c<10 || (c>10 && c<32) || (c>126 && c<160))\
1782              return RT__Err(33,c);\
1783            if (c>=0 && c<256)\
1784              @streamchar c;\
1785            else\
1786              @streamunichar c;\
1787          ]", "", "", "", "", ""
1788     },
1789     {
1790         /*  RT__ChPrintA: Check at run-time that it's safe to print (address)
1791             and do so.
1792         */
1793         "RT__ChPrintA",
1794         "addr endmem;\
1795            if (addr<36)\
1796              return RT__Err(34);\
1797            @getmemsize endmem;\
1798            if (Unsigned__Compare(addr, endmem) >= 0)\
1799              return RT__Err(34);\
1800            if (addr->0 ~= $60)\
1801              return RT__Err(34);\
1802            Print__Addr(addr);\
1803          ]", "", "", "", "", ""
1804     },
1805     {
1806         /*  Check at run-time that it's safe to print (string) and do so.
1807         */
1808         "RT__ChPrintS",
1809         "str;\
1810            if (Z__Region(str) ~= 3)\
1811              return RT__Err(35);\
1812            @streamstr str;\
1813          ]", "", "", "", "", ""
1814     },
1815     {
1816         /*  Check at run-time that it's safe to print (object) and do so.
1817         */
1818         "RT__ChPrintO",
1819         "obj;\
1820            if (Z__Region(obj) ~= 1)\
1821              return RT__Err(36);\
1822            @aload obj GOBJFIELD_NAME sp; @streamstr sp;\
1823          ]", "", "", "", "", ""
1824     },
1825     {
1826         /*  OB__Move: Move an object within the object tree. This does no
1827             more error checking than the Z-code \"move\" opcode.
1828         */
1829         "OB__Move",
1830         "obj dest par chi sib;\
1831            par = obj-->GOBJFIELD_PARENT;\
1832            if (par ~= 0) {\
1833              chi = par-->GOBJFIELD_CHILD;\
1834              if (chi == obj) {\
1835                par-->GOBJFIELD_CHILD = obj-->GOBJFIELD_SIBLING;\
1836              }\
1837              else {\
1838                while (1) {\
1839                  sib = chi-->GOBJFIELD_SIBLING;\
1840                  if (sib == obj)\
1841                    break;\
1842                  chi = sib;\
1843                }\
1844                chi-->GOBJFIELD_SIBLING = obj-->GOBJFIELD_SIBLING;\
1845              }\
1846            }\
1847            obj-->GOBJFIELD_SIBLING = dest-->GOBJFIELD_CHILD;\
1848            obj-->GOBJFIELD_PARENT = dest;\
1849            dest-->GOBJFIELD_CHILD = obj;\
1850            rfalse;\
1851          ]", "", "", "", "", ""
1852     },
1853
1854     {
1855         /*  OB__Remove: Remove an object from the tree. This does no
1856             more error checking than the Z-code \"remove\" opcode.
1857         */
1858         "OB__Remove",
1859         "obj par chi sib;\
1860            par = obj-->GOBJFIELD_PARENT;\
1861            if (par == 0)\
1862              rfalse;\
1863            chi = par-->GOBJFIELD_CHILD;\
1864            if (chi == obj) {\
1865              par-->GOBJFIELD_CHILD = obj-->GOBJFIELD_SIBLING;\
1866            }\
1867            else {\
1868              while (1) {\
1869                sib = chi-->GOBJFIELD_SIBLING;\
1870                if (sib == obj)\
1871                  break;\
1872                chi = sib;\
1873              }\
1874              chi-->GOBJFIELD_SIBLING = obj-->GOBJFIELD_SIBLING;\
1875            }\
1876            obj-->GOBJFIELD_SIBLING = 0;\
1877            obj-->GOBJFIELD_PARENT = 0;\
1878            rfalse;\
1879          ]", "", "", "", "", ""
1880     },
1881
1882     {
1883         /*  Print__Addr: Handle the print (address) statement. In Glulx,
1884             this behaves differently than on the Z-machine; it can *only*
1885             print dictionary words.
1886         */
1887         "Print__Addr",
1888         "addr ix ch;\
1889            if (addr->0 ~= $60) {\
1890              print \"(\", addr, \": not dict word)\";\
1891              return;\
1892            }\
1893            for (ix=1 : ix <= DICT_WORD_SIZE : ix++) {\
1894              #ifndef DICT_IS_UNICODE;\
1895              ch = addr->ix;\
1896              #ifnot;\
1897              ch = addr-->ix;\
1898              #endif;\
1899              if (ch == 0) return;\
1900              print (char) ch;\
1901            }\
1902          ]", "", "", "", "", ""
1903     },
1904
1905     {
1906         /*  Glk__Wrap: This is a wrapper for the @glk opcode. It just passes
1907             all its arguments into the Glk dispatcher, and returns the Glk
1908             call result.
1909         */
1910         "Glk__Wrap",
1911         "_vararg_count callid retval;\
1912            @copy sp callid;\
1913            _vararg_count = _vararg_count - 1;\
1914            @glk callid _vararg_count retval;\
1915            return retval;\
1916          ]", "", "", "", "", ""
1917     },
1918
1919     {
1920         /*  Dynam__String: Set dynamic string (printing variable) num to the
1921             given val, which can be any string or function.
1922         */
1923         "Dynam__String",
1924         "num val;\
1925            if (num < 0 || num >= #dynam_string_table-->0)\
1926              return RT__Err(40, num);\
1927            (#dynam_string_table)-->(num+1) = val;\
1928          ]", "", "", "", "", ""
1929     }
1930
1931 };
1932
1933
1934 static void mark_as_needed_z(int code)
1935 {
1936     ASSERT_ZCODE();
1937     if (veneer_routine_needs_compilation[code] == VR_UNUSED)
1938     {   veneer_routine_needs_compilation[code] = VR_CALLED;
1939         /* Here each routine must mark every veneer routine it explicitly
1940            calls as needed */
1941         switch(code)
1942         {   case WV__Pr_VR:
1943                 mark_as_needed_z(RT__TrPS_VR);
1944                 mark_as_needed_z(RT__Err_VR);
1945                 return;
1946             case RV__Pr_VR:
1947                 mark_as_needed_z(RT__Err_VR);
1948                 return;
1949             case CA__Pr_VR:
1950                 mark_as_needed_z(Z__Region_VR);
1951                 mark_as_needed_z(Cl__Ms_VR);
1952                 mark_as_needed_z(RT__Err_VR);
1953                 return;
1954             case IB__Pr_VR:
1955             case IA__Pr_VR:
1956             case DB__Pr_VR:
1957             case DA__Pr_VR:
1958                 mark_as_needed_z(RT__Err_VR);
1959                 mark_as_needed_z(RT__TrPS_VR);
1960                 return;
1961             case RA__Pr_VR:
1962                 mark_as_needed_z(CP__Tab_VR);
1963                 return;
1964             case RA__Sc_VR:
1965                 mark_as_needed_z(RT__Err_VR);
1966                 return;
1967             case OP__Pr_VR:
1968                 mark_as_needed_z(Z__Region_VR);
1969                 return;
1970             case OC__Cl_VR:
1971                 mark_as_needed_z(Z__Region_VR);
1972                 mark_as_needed_z(RT__Err_VR);
1973                 return;
1974             case Z__Region_VR:
1975                 mark_as_needed_z(Unsigned__Compare_VR);
1976                 return;
1977             case Metaclass_VR:
1978                 mark_as_needed_z(Z__Region_VR);
1979                 return;
1980             case Cl__Ms_VR:
1981                 mark_as_needed_z(RT__Err_VR);
1982                 mark_as_needed_z(Copy__Primitive_VR);
1983                 return;
1984             case RT__ChR_VR:
1985             case RT__ChT_VR:
1986             case RT__ChG_VR:
1987             case RT__ChGt_VR:
1988             case RT__ChPR_VR:
1989                 mark_as_needed_z(RT__Err_VR);
1990                 return;
1991             case RT__ChPS_VR:
1992                 mark_as_needed_z(RT__Err_VR);
1993                 mark_as_needed_z(RT__TrPS_VR);
1994                 return;
1995             case RT__ChLDB_VR:
1996             case RT__ChLDW_VR:
1997             case RT__ChSTB_VR:
1998             case RT__ChSTW_VR:
1999                 mark_as_needed_z(Unsigned__Compare_VR);
2000                 mark_as_needed_z(RT__Err_VR);
2001                 return;
2002             case RT__ChPrintC_VR:
2003                 mark_as_needed_z(RT__Err_VR);
2004                 return;
2005             case RT__ChPrintA_VR:
2006                 mark_as_needed_z(Unsigned__Compare_VR);
2007                 mark_as_needed_z(RT__Err_VR);
2008                 return;
2009             case RT__ChPrintS_VR:
2010             case RT__ChPrintO_VR:
2011                 mark_as_needed_z(RT__Err_VR);
2012                 mark_as_needed_z(Z__Region_VR);
2013                 return;
2014         }
2015     }
2016 }
2017
2018 static void mark_as_needed_g(int code)
2019 {
2020     ASSERT_GLULX();
2021     if (veneer_routine_needs_compilation[code] == VR_UNUSED)
2022     {   veneer_routine_needs_compilation[code] = VR_CALLED;
2023         /* Here each routine must mark every veneer routine it explicitly
2024            calls as needed */
2025         switch(code)
2026         {
2027             case PrintShortName_VR:
2028                 mark_as_needed_g(Metaclass_VR);
2029                 return;
2030             case Print__Pname_VR:
2031                 mark_as_needed_g(PrintShortName_VR);
2032                 return;
2033             case WV__Pr_VR:
2034                 mark_as_needed_g(RA__Pr_VR);
2035                 mark_as_needed_g(RT__TrPS_VR);
2036                 mark_as_needed_g(RT__Err_VR);
2037                 return;
2038             case RV__Pr_VR:
2039                 mark_as_needed_g(RA__Pr_VR);
2040                 mark_as_needed_g(RT__Err_VR);
2041                 return;
2042             case CA__Pr_VR:
2043                 mark_as_needed_g(RA__Pr_VR);
2044                 mark_as_needed_g(RL__Pr_VR);
2045                 mark_as_needed_g(PrintShortName_VR);
2046                 mark_as_needed_g(Print__Pname_VR);
2047                 mark_as_needed_g(Z__Region_VR);
2048                 mark_as_needed_g(Cl__Ms_VR);
2049                 mark_as_needed_g(Glk__Wrap_VR);
2050                 mark_as_needed_g(RT__Err_VR);
2051                 return;
2052             case IB__Pr_VR:
2053             case IA__Pr_VR:
2054             case DB__Pr_VR:
2055             case DA__Pr_VR:
2056                 mark_as_needed_g(RT__Err_VR);
2057                 mark_as_needed_g(RT__TrPS_VR);
2058                 return;
2059             case RA__Pr_VR:
2060                 mark_as_needed_g(OC__Cl_VR);
2061                 mark_as_needed_g(CP__Tab_VR);
2062                 return;
2063             case RL__Pr_VR:
2064                 mark_as_needed_g(OC__Cl_VR);
2065                 mark_as_needed_g(CP__Tab_VR);
2066                 return;
2067             case RA__Sc_VR:
2068                 mark_as_needed_g(OC__Cl_VR);
2069                 mark_as_needed_g(RT__Err_VR);
2070                 return;
2071             case OP__Pr_VR:
2072                 mark_as_needed_g(RA__Pr_VR);
2073                 mark_as_needed_g(Z__Region_VR);
2074                 return;
2075             case OC__Cl_VR:
2076                 mark_as_needed_g(RA__Pr_VR);
2077                 mark_as_needed_g(RL__Pr_VR);
2078                 mark_as_needed_g(Z__Region_VR);
2079                 mark_as_needed_g(RT__Err_VR);
2080                 return;
2081             case Copy__Primitive_VR:
2082                 mark_as_needed_g(CP__Tab_VR);
2083                 return;
2084             case Z__Region_VR:
2085                 mark_as_needed_g(Unsigned__Compare_VR);
2086                 return;
2087             case CP__Tab_VR:
2088             case Metaclass_VR:
2089                 mark_as_needed_g(Z__Region_VR);
2090                 return;
2091             case Cl__Ms_VR:
2092                 mark_as_needed_g(OC__Cl_VR);
2093                 mark_as_needed_g(OP__Pr_VR);
2094                 mark_as_needed_g(RT__Err_VR);
2095                 mark_as_needed_g(Copy__Primitive_VR);
2096                 mark_as_needed_g(OB__Remove_VR);
2097                 mark_as_needed_g(OB__Move_VR);
2098                 return;
2099             case RT__ChG_VR:
2100             case RT__ChGt_VR:
2101                 mark_as_needed_g(RT__Err_VR);
2102                 return;
2103             case RT__ChR_VR:
2104                 mark_as_needed_g(RT__Err_VR);
2105                 mark_as_needed_g(Z__Region_VR);
2106                 mark_as_needed_g(OB__Remove_VR);
2107                 return;
2108             case RT__ChT_VR:
2109                 mark_as_needed_g(RT__Err_VR);
2110                 mark_as_needed_g(Z__Region_VR);
2111                 mark_as_needed_g(OB__Move_VR);
2112                 return;
2113             case RT__ChPS_VR:
2114                 mark_as_needed_g(RT__Err_VR);
2115                 mark_as_needed_g(RT__TrPS_VR);
2116                 mark_as_needed_g(WV__Pr_VR);
2117                 return;
2118             case RT__ChPR_VR:
2119                 mark_as_needed_g(RT__Err_VR);
2120                 mark_as_needed_g(RV__Pr_VR); return;
2121             case RT__ChLDB_VR:
2122             case RT__ChLDW_VR:
2123             case RT__ChSTB_VR:
2124             case RT__ChSTW_VR:
2125                 mark_as_needed_g(Unsigned__Compare_VR);
2126                 mark_as_needed_g(RT__Err_VR);
2127                 return;
2128             case RT__ChPrintC_VR:
2129                 mark_as_needed_g(RT__Err_VR);
2130                 return;
2131             case RT__ChPrintA_VR:
2132                 mark_as_needed_g(Unsigned__Compare_VR);
2133                 mark_as_needed_g(RT__Err_VR);
2134                 mark_as_needed_g(Print__Addr_VR);
2135                 return;
2136             case RT__ChPrintS_VR:
2137             case RT__ChPrintO_VR:
2138                 mark_as_needed_g(RT__Err_VR);
2139                 mark_as_needed_g(Z__Region_VR);
2140                 return;
2141             case Print__Addr_VR:
2142                 mark_as_needed_g(RT__Err_VR);
2143                 return;
2144             case Dynam__String_VR:
2145                 mark_as_needed_g(RT__Err_VR);
2146                 return;
2147         }
2148     }
2149 }
2150
2151 extern assembly_operand veneer_routine(int code)
2152 {   assembly_operand AO;
2153     if (!glulx_mode) {
2154         AO.type = LONG_CONSTANT_OT;
2155         AO.marker = VROUTINE_MV;
2156         AO.value = code;
2157         mark_as_needed_z(code);
2158     }
2159     else {
2160         AO.type = CONSTANT_OT;
2161         AO.marker = VROUTINE_MV;
2162         AO.value = code;
2163         mark_as_needed_g(code);
2164     }
2165     return(AO);
2166 }
2167
2168 static void compile_symbol_table_routine(void)
2169 {   int32 j, nl, arrays_l, routines_l, constants_l;
2170     assembly_operand AO, AO2, AO3;
2171
2172     /* Assign local var names for the benefit of the debugging information
2173        file. */
2174     local_variable_texts[0] = "dummy1";
2175     local_variable_texts[1] = "dummy2";
2176
2177     veneer_mode = TRUE; j = symbol_index("Symb__Tab", -1);
2178     assign_symbol(j,
2179         assemble_routine_header(2, FALSE, "Symb__Tab", FALSE, j),
2180         ROUTINE_T);
2181     sflags[j] |= SYSTEM_SFLAG + USED_SFLAG;
2182     if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG;
2183
2184   if (!glulx_mode) {
2185
2186     if (define_INFIX_switch == FALSE)
2187     {   assemblez_0(rfalse_zc);
2188         variable_usage[1] = TRUE;
2189         variable_usage[2] = TRUE;
2190         assemble_routine_end(FALSE, null_debug_locations);
2191         veneer_mode = FALSE;
2192         return;
2193     }
2194
2195     AO.value = 1; AO.type = VARIABLE_OT; AO.marker = 0;
2196     AO2.type = SHORT_CONSTANT_OT; AO2.marker = 0;
2197     AO3.type = LONG_CONSTANT_OT; AO3.marker = 0;
2198
2199     arrays_l = next_label++;
2200     routines_l = next_label++;
2201     constants_l = next_label++;
2202
2203     sequence_point_follows = FALSE;
2204     AO2.value = 1;
2205     assemblez_2_branch(je_zc, AO, AO2, arrays_l, TRUE);
2206     sequence_point_follows = FALSE;
2207     AO2.value = 2;
2208     assemblez_2_branch(je_zc, AO, AO2, routines_l, TRUE);
2209     sequence_point_follows = FALSE;
2210     AO2.value = 3;
2211     assemblez_2_branch(je_zc, AO, AO2, constants_l, TRUE);
2212     sequence_point_follows = FALSE;
2213     assemblez_0(rtrue_zc);
2214
2215     assemble_label_no(arrays_l);
2216     AO.value = 2;
2217     for (j=0; j<no_arrays; j++)
2218     {   {   AO2.value = j;
2219             if (AO2.value<256) AO2.type = SHORT_CONSTANT_OT;
2220             else AO2.type = LONG_CONSTANT_OT;
2221             nl = next_label++;
2222             sequence_point_follows = FALSE;
2223             assemblez_2_branch(je_zc, AO, AO2, nl, FALSE);
2224             AO3.value = array_sizes[j];
2225             AO3.marker = 0;
2226             assemblez_store(temp_var2, AO3);
2227             AO3.value = array_types[j];
2228             if (sflags[array_symbols[j]] & (INSF_SFLAG+SYSTEM_SFLAG))
2229                 AO3.value = AO3.value + 16;
2230             AO3.marker = 0;
2231             assemblez_store(temp_var3, AO3);
2232             AO3.value = svals[array_symbols[j]];
2233             AO3.marker = ARRAY_MV;
2234             assemblez_1(ret_zc, AO3);
2235             assemble_label_no(nl);
2236         }
2237     }
2238     sequence_point_follows = FALSE;
2239     assemblez_0(rtrue_zc);
2240     assemble_label_no(routines_l);
2241     for (j=0; j<no_named_routines; j++)
2242     {   AO2.value = j;
2243         if (AO2.value<256) AO2.type = SHORT_CONSTANT_OT;
2244         else AO2.type = LONG_CONSTANT_OT;
2245         nl = next_label++;
2246         sequence_point_follows = FALSE;
2247         assemblez_2_branch(je_zc, AO, AO2, nl, FALSE);
2248         AO3.value = 0;
2249         if (sflags[named_routine_symbols[j]]
2250             & (INSF_SFLAG+SYSTEM_SFLAG)) AO3.value = 16;
2251         AO3.marker = 0;
2252         assemblez_store(temp_var3, AO3);
2253         AO3.value = svals[named_routine_symbols[j]];
2254         AO3.marker = IROUTINE_MV;
2255         assemblez_1(ret_zc, AO3);
2256         assemble_label_no(nl);
2257     }
2258     sequence_point_follows = FALSE;
2259     assemblez_0(rtrue_zc);
2260
2261     assemble_label_no(constants_l);
2262     for (j=0, no_named_constants=0; j<no_symbols; j++)
2263     {   if (((stypes[j] == OBJECT_T) || (stypes[j] == CLASS_T)
2264             || (stypes[j] == CONSTANT_T))
2265             && ((sflags[j] & (UNKNOWN_SFLAG+ACTION_SFLAG))==0))
2266         {   AO2.value = no_named_constants++;
2267             if (AO2.value<256) AO2.type = SHORT_CONSTANT_OT;
2268             else AO2.type = LONG_CONSTANT_OT;
2269             nl = next_label++;
2270             sequence_point_follows = FALSE;
2271             assemblez_2_branch(je_zc, AO, AO2, nl, FALSE);
2272             AO3.value = 0;
2273             if (stypes[j] == OBJECT_T) AO3.value = 2;
2274             if (stypes[j] == CLASS_T) AO3.value = 1;
2275             if (sflags[j] & (INSF_SFLAG+SYSTEM_SFLAG))
2276                 AO3.value = AO3.value + 16;
2277             AO3.marker = 0;
2278             assemblez_store(temp_var3, AO3);
2279             AO3.value = j;
2280             AO3.marker = SYMBOL_MV;
2281             assemblez_1(ret_zc, AO3);
2282             assemble_label_no(nl);
2283         }
2284     }
2285     no_named_constants = 0; AO3.marker = 0;
2286
2287     sequence_point_follows = FALSE;
2288     assemblez_0(rfalse_zc);
2289     variable_usage[1] = TRUE;
2290     variable_usage[2] = TRUE;
2291     assemble_routine_end(FALSE, null_debug_locations);
2292     veneer_mode = FALSE;
2293   }
2294   else {
2295
2296     if (define_INFIX_switch == FALSE)
2297     {   assembleg_1(return_gc, zero_operand);
2298         variable_usage[1] = TRUE;
2299         variable_usage[2] = TRUE;
2300         assemble_routine_end(FALSE, null_debug_locations);
2301         veneer_mode = FALSE;
2302         return;
2303     }
2304
2305     error("*** Infix symbol-table routine is not yet implemented. ***");
2306   }
2307 }
2308
2309 extern void compile_veneer(void)
2310 {   int i, j, try_veneer_again;
2311     VeneerRoutine *VRs;
2312
2313     if (module_switch) return;
2314
2315     VRs = (!glulx_mode) ? VRs_z : VRs_g;
2316
2317     /*  Called at the end of the pass to insert as much of the veneer as is
2318         needed and not elsewhere compiled.  */
2319
2320     veneer_symbols_base = no_symbols;
2321
2322     /*  for (i=0; i<VENEER_ROUTINES; i++)
2323         printf("%s %d %d %d %d %d %d\n", VRs[i].name,
2324             strlen(VRs[i].source1), strlen(VRs[i].source2),
2325             strlen(VRs[i].source3), strlen(VRs[i].source4),
2326             strlen(VRs[i].source5), strlen(VRs[i].source6)); */
2327
2328     try_veneer_again = TRUE;
2329     while (try_veneer_again)
2330     {   try_veneer_again = FALSE;
2331         for (i=0; i<VENEER_ROUTINES; i++)
2332         {   if (veneer_routine_needs_compilation[i] == VR_CALLED)
2333             {   j = symbol_index(VRs[i].name, -1);
2334                 if (sflags[j] & UNKNOWN_SFLAG)
2335                 {   veneer_mode = TRUE;
2336                     strcpy(veneer_source_area, VRs[i].source1);
2337                     strcat(veneer_source_area, VRs[i].source2);
2338                     strcat(veneer_source_area, VRs[i].source3);
2339                     strcat(veneer_source_area, VRs[i].source4);
2340                     strcat(veneer_source_area, VRs[i].source5);
2341                     strcat(veneer_source_area, VRs[i].source6);
2342                     assign_symbol(j,
2343                         parse_routine(veneer_source_area, FALSE,
2344                             VRs[i].name, TRUE, j),
2345                         ROUTINE_T);
2346                     veneer_mode = FALSE;
2347                     if (trace_fns_setting==3) sflags[j] |= STAR_SFLAG;
2348                 }
2349                 else
2350                 {   if (stypes[j] != ROUTINE_T)
2351                 error_named("The following name is reserved by Inform for its \
2352 own use as a routine name; you can use it as a routine name yourself (to \
2353 override the standard definition) but cannot use it for anything else:",
2354                         VRs[i].name);
2355                     else
2356                         sflags[j] |= USED_SFLAG;
2357                 }
2358                 veneer_routine_address[i] = svals[j];
2359                 veneer_routine_needs_compilation[i] = VR_COMPILED;
2360                 try_veneer_again = TRUE;
2361             }
2362         }
2363     }
2364
2365     compile_symbol_table_routine();
2366 }
2367
2368 /* ========================================================================= */
2369 /*   Data structure management routines                                      */
2370 /* ------------------------------------------------------------------------- */
2371
2372 extern void init_veneer_vars(void)
2373 {
2374 }
2375
2376 extern void veneer_begin_pass(void)
2377 {   int i;
2378     veneer_mode = FALSE;
2379     for (i=0; i<VENEER_ROUTINES; i++)
2380     {   veneer_routine_needs_compilation[i] = VR_UNUSED;
2381         veneer_routine_address[i] = 0;
2382     }
2383 }
2384
2385 extern void veneer_allocate_arrays(void)
2386 {   veneer_source_area = my_malloc(16384, "veneer source code area");
2387 }
2388
2389 extern void veneer_free_arrays(void)
2390 {   my_free(&veneer_source_area, "veneer source code area");
2391 }
2392
2393 /* ========================================================================= */