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