src/veneer.c

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