src/veneer.c

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