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