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