src/objects.c

   1 /* ------------------------------------------------------------------------- */
   2 /*   "objects" :  [1] the object-maker, which constructs objects and enters  */
   3 /*                    them into the tree, given a low-level specification;   */
   4 /*                                                                           */
   5 /*                [2] the parser of Object/Nearby/Class directives, which    */
   6 /*                    checks syntax and translates such directives into      */
   7 /*                    specifications for the object-maker.                   */
   8 /*                                                                           */
   9 /*   Part of Inform 6.35                                                     */
  10 /*   copyright (c) Graham Nelson 1993 - 2021                                 */
  11 /*                                                                           */
  12 /* Inform is free software: you can redistribute it and/or modify            */
  13 /* it under the terms of the GNU General Public License as published by      */
  14 /* the Free Software Foundation, either version 3 of the License, or         */
  15 /* (at your option) any later version.                                       */
  16 /*                                                                           */
  17 /* Inform is distributed in the hope that it will be useful,                 */
  18 /* but WITHOUT ANY WARRANTY; without even the implied warranty of            */
  19 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the              */
  20 /* GNU General Public License for more details.                              */
  21 /*                                                                           */
  22 /* You should have received a copy of the GNU General Public License         */
  23 /* along with Inform. If not, see https://gnu.org/licenses/                  *
  24 /*                                                                           */
  25 /* ------------------------------------------------------------------------- */
  26
  27 #include "header.h"
  28
  29 /* ------------------------------------------------------------------------- */
  30 /*   Objects.                                                                */
  31 /* ------------------------------------------------------------------------- */
  32
  33 int no_objects;                        /* Number of objects made so far      */
  34
  35 static int no_embedded_routines;       /* Used for naming routines which
  36                                           are given as property values: these
  37                                           are called EmbeddedRoutine__1, ... */
  38
  39 static fpropt full_object;             /* "fpropt" is a typedef for a struct
  40                                           containing an array to hold the
  41                                           attribute and property values of
  42                                           a single object.  We only keep one
  43                                           of these, for the current object
  44                                           being made, and compile it into
  45                                           Z-machine tables when each object
  46                                           definition is complete, since
  47                                           sizeof(fpropt) is about 6200 bytes */
  48 static fproptg full_object_g;          /* Equivalent for Glulx. This object
  49                                           is very small, since the large arrays
  50                                           are allocated dynamically by the
  51                                           Glulx compiler                     */
  52 static char shortname_buffer[766];     /* Text buffer to hold the short name
  53                                           (which is read in first, but
  54                                           written almost last)               */
  55 static int parent_of_this_obj;
  56
  57 static char *classname_text, *objectname_text;
  58                                        /* For printing names of embedded
  59                                           routines only                      */
  60
  61 /* ------------------------------------------------------------------------- */
  62 /*   Classes.                                                                */
  63 /* ------------------------------------------------------------------------- */
  64 /*   Arrays defined below:                                                   */
  65 /*                                                                           */
  66 /*    int32 class_begins_at[n]            offset of properties block for     */
  67 /*                                        nth class (always an offset        */
  68 /*                                        inside the properties_table)       */
  69 /*    int   classes_to_inherit_from[]     The list of classes to inherit     */
  70 /*                                        from as taken from the current     */
  71 /*                                        Nearby/Object/Class definition     */
  72 /*    int   class_object_numbers[n]       The number of the prototype-object */
  73 /*                                        for the nth class                  */
  74 /* ------------------------------------------------------------------------- */
  75
  76 int        no_classes;                 /* Number of class defns made so far  */
  77
  78 static int current_defn_is_class,      /* TRUE if current Nearby/Object/Class
  79                                           defn is in fact a Class definition */
  80            no_classes_to_inherit_from; /* Number of classes in the list
  81                                           of classes to inherit in the
  82                                           current Nearby/Object/Class defn   */
  83
  84 /* ------------------------------------------------------------------------- */
  85 /*   Making attributes and properties.                                       */
  86 /* ------------------------------------------------------------------------- */
  87
  88 int no_attributes,                 /* Number of attributes defined so far    */
  89     no_properties;                 /* Number of properties defined so far,
  90                                       plus 1 (properties are numbered from
  91                                       1 and Inform creates "name" and two
  92                                       others itself, so the variable begins
  93                                       the compilation pass set to 4)         */
  94
  95 static void trace_s(char *name, int32 number, int f)
  96 {   if (!printprops_switch) return;
  97     printf("%s  %02ld  ",(f==0)?"Attr":"Prop",(long int) number);
  98     if (f==0) printf("  ");
  99     else      printf("%s%s",(prop_is_long[number])?"L":" ",
 100                             (prop_is_additive[number])?"A":" ");
 101     printf("  %s\n",name);
 102 }
 103
 104 extern void make_attribute(void)
 105 {   int i; char *name;
 106     debug_location_beginning beginning_debug_location =
 107         get_token_location_beginning();
 108
 109  if (!glulx_mode) {
 110     if (no_attributes==((version_number==3)?32:48))
 111     {   discard_token_location(beginning_debug_location);
 112         if (version_number==3)
 113             error("All 32 attributes already declared (compile as Advanced \
 114 game to get an extra 16)");
 115         else
 116             error("All 48 attributes already declared");
 117         panic_mode_error_recovery();
 118         put_token_back();
 119         return;
 120     }
 121  }
 122  else {
 123     if (no_attributes==NUM_ATTR_BYTES*8) {
 124       discard_token_location(beginning_debug_location);
 125       error_numbered(
 126         "All attributes already declared -- increase NUM_ATTR_BYTES to use \
 127 more than",
 128         NUM_ATTR_BYTES*8);
 129       panic_mode_error_recovery();
 130       put_token_back();
 131       return;
 132     }
 133  }
 134
 135     get_next_token();
 136     i = token_value; name = token_text;
 137     if (token_type != SYMBOL_TT)
 138     {   discard_token_location(beginning_debug_location);
 139         ebf_error("new attribute name", token_text);
 140         panic_mode_error_recovery();
 141         put_token_back();
 142         return;
 143     }
 144     if (!(sflags[i] & UNKNOWN_SFLAG))
 145     {   discard_token_location(beginning_debug_location);
 146         ebf_symbol_error("new attribute name", token_text, typename(stypes[i]), slines[i]);
 147         panic_mode_error_recovery();
 148         put_token_back();
 149         return;
 150     }
 151
 152     directive_keywords.enabled = TRUE;
 153     get_next_token();
 154     directive_keywords.enabled = FALSE;
 155
 156     if ((token_type == DIR_KEYWORD_TT) && (token_value == ALIAS_DK))
 157     {   get_next_token();
 158         if (!((token_type == SYMBOL_TT)
 159               && (stypes[token_value] == ATTRIBUTE_T)))
 160         {   discard_token_location(beginning_debug_location);
 161             ebf_error("an existing attribute name after 'alias'",
 162                 token_text);
 163             panic_mode_error_recovery();
 164             put_token_back();
 165             return;
 166         }
 167         assign_symbol(i, svals[token_value], ATTRIBUTE_T);
 168         sflags[token_value] |= ALIASED_SFLAG;
 169         sflags[i] |= ALIASED_SFLAG;
 170     }
 171     else
 172     {   assign_symbol(i, no_attributes++, ATTRIBUTE_T);
 173         put_token_back();
 174     }
 175
 176     if (debugfile_switch)
 177     {   debug_file_printf("<attribute>");
 178         debug_file_printf("<identifier>%s</identifier>", name);
 179         debug_file_printf("<value>%d</value>", svals[i]);
 180         write_debug_locations(get_token_location_end(beginning_debug_location));
 181         debug_file_printf("</attribute>");
 182     }
 183
 184     trace_s(name, svals[i], 0);
 185     return;
 186 }
 187
 188 extern void make_property(void)
 189 {   int32 default_value, i;
 190     int additive_flag=FALSE; char *name;
 191     assembly_operand AO;
 192     debug_location_beginning beginning_debug_location =
 193         get_token_location_beginning();
 194
 195     if (!glulx_mode) {
 196         if (no_properties==((version_number==3)?32:64))
 197         {   discard_token_location(beginning_debug_location);
 198             if (version_number==3)
 199                 error("All 30 properties already declared (compile as \
 200 Advanced game to get an extra 62)");
 201             else
 202                 error("All 62 properties already declared");
 203             panic_mode_error_recovery();
 204             put_token_back();
 205             return;
 206         }
 207     }
 208     else {
 209         if (no_properties==INDIV_PROP_START) {
 210             discard_token_location(beginning_debug_location);
 211             error_numbered("All properties already declared -- max is",
 212                 INDIV_PROP_START);
 213             panic_mode_error_recovery();
 214             put_token_back();
 215             return;
 216         }
 217     }
 218
 219     do
 220     {   directive_keywords.enabled = TRUE;
 221         get_next_token();
 222         if ((token_type == DIR_KEYWORD_TT) && (token_value == LONG_DK))
 223             obsolete_warning("all properties are now automatically 'long'");
 224         else
 225         if ((token_type == DIR_KEYWORD_TT) && (token_value == ADDITIVE_DK))
 226             additive_flag = TRUE;
 227         else break;
 228     } while (TRUE);
 229
 230     put_token_back();
 231     directive_keywords.enabled = FALSE;
 232     get_next_token();
 233
 234     i = token_value; name = token_text;
 235     if (token_type != SYMBOL_TT)
 236     {   discard_token_location(beginning_debug_location);
 237         ebf_error("new property name", token_text);
 238         panic_mode_error_recovery();
 239         put_token_back();
 240         return;
 241     }
 242     if (!(sflags[i] & UNKNOWN_SFLAG))
 243     {   discard_token_location(beginning_debug_location);
 244         ebf_symbol_error("new property name", token_text, typename(stypes[i]), slines[i]);
 245         panic_mode_error_recovery();
 246         put_token_back();
 247         return;
 248     }
 249
 250     directive_keywords.enabled = TRUE;
 251     get_next_token();
 252     directive_keywords.enabled = FALSE;
 253
 254     if (strcmp(name+strlen(name)-3, "_to") == 0) sflags[i] |= STAR_SFLAG;
 255
 256     if ((token_type == DIR_KEYWORD_TT) && (token_value == ALIAS_DK))
 257     {   discard_token_location(beginning_debug_location);
 258         if (additive_flag)
 259         {   error("'alias' incompatible with 'additive'");
 260             panic_mode_error_recovery();
 261             put_token_back();
 262             return;
 263         }
 264         get_next_token();
 265         if (!((token_type == SYMBOL_TT)
 266             && (stypes[token_value] == PROPERTY_T)))
 267         {   ebf_error("an existing property name after 'alias'",
 268                 token_text);
 269             panic_mode_error_recovery();
 270             put_token_back();
 271             return;
 272         }
 273
 274         assign_symbol(i, svals[token_value], PROPERTY_T);
 275         trace_s(name, svals[i], 1);
 276         sflags[token_value] |= ALIASED_SFLAG;
 277         sflags[i] |= ALIASED_SFLAG;
 278         return;
 279     }
 280
 281     default_value = 0;
 282     put_token_back();
 283
 284     if (!((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
 285     {   AO = parse_expression(CONSTANT_CONTEXT);
 286         default_value = AO.value;
 287         if (AO.marker != 0)
 288             backpatch_zmachine(AO.marker, PROP_DEFAULTS_ZA,
 289                 (no_properties-1) * WORDSIZE);
 290     }
 291
 292     prop_default_value[no_properties] = default_value;
 293     prop_is_long[no_properties] = TRUE;
 294     prop_is_additive[no_properties] = additive_flag;
 295
 296     assign_symbol(i, no_properties++, PROPERTY_T);
 297
 298     if (debugfile_switch)
 299     {   debug_file_printf("<property>");
 300         debug_file_printf("<identifier>%s</identifier>", name);
 301         debug_file_printf("<value>%d</value>", svals[i]);
 302         write_debug_locations
 303             (get_token_location_end(beginning_debug_location));
 304         debug_file_printf("</property>");
 305     }
 306
 307     trace_s(name, svals[i], 1);
 308 }
 309
 310 /* ------------------------------------------------------------------------- */
 311 /*   Properties.                                                             */
 312 /* ------------------------------------------------------------------------- */
 313
 314 int32 *prop_default_value;             /* Default values for properties      */
 315 int   *prop_is_long,                   /* Property modifiers, TRUE or FALSE:
 316                                           "long" means "never write a 1-byte
 317                                           value to this property", and is an
 318                                           obsolete feature: since Inform 5
 319                                           all properties have been "long"    */
 320       *prop_is_additive;               /* "additive" means that values
 321                                           accumulate rather than erase each
 322                                           other during class inheritance     */
 323 char *properties_table;                /* Holds the table of property values
 324                                           (holding one block for each object
 325                                           and coming immediately after the
 326                                           object tree in Z-memory)           */
 327 int properties_table_size;             /* Number of bytes in this table      */
 328
 329 /* ------------------------------------------------------------------------- */
 330 /*   Individual properties                                                   */
 331 /*                                                                           */
 332 /*   Each new i.p. name is given a unique number.  These numbers start from  */
 333 /*   72, since 0 is reserved as a null, 1 to 63 refer to common properties   */
 334 /*   and 64 to 71 are kept for methods of the metaclass Class (for example,  */
 335 /*   64 is "create").                                                        */
 336 /*                                                                           */
 337 /*   An object provides individual properties by having property 3 set to a  */
 338 /*   non-zero value, which must be a byte address of a table in the form:    */
 339 /*                                                                           */
 340 /*       <record-1> ... <record-n> 00 00                                     */
 341 /*                                                                           */
 342 /*   where a <record> looks like                                             */
 343 /*                                                                           */
 344 /*       <identifier>              <size>  <up to 255 bytes of data>         */
 345 /*       or <identifier + 0x8000>                                            */
 346 /*       ----- 2 bytes ----------  1 byte  <size> number of bytes            */
 347 /*                                                                           */
 348 /*   The <identifier> part is the number allocated to the name of what is    */
 349 /*   being provided.  The top bit of this word is set to indicate that       */
 350 /*   although the individual property is being provided, it is provided      */
 351 /*   only privately (so that it is inaccessible except to the object's own   */
 352 /*   embedded routines).                                                     */
 353 /*                                                                           */
 354 /*   In Glulx: i-props are numbered from INDIV_PROP_START+8 up. And all      */
 355 /*   properties, common and individual, are stored in the same table.        */
 356 /* ------------------------------------------------------------------------- */
 357
 358        int no_individual_properties;   /* Actually equal to the next
 359                                           identifier number to be allocated,
 360                                           so this is initially 72 even though
 361                                           none have been made yet.           */
 362 static int individual_prop_table_size; /* Size of the table of individual
 363                                           properties so far for current obj  */
 364        uchar *individuals_table;       /* Table of records, each being the
 365                                           i.p. table for an object           */
 366        int i_m;                        /* Write mark position in the above   */
 367        int individuals_length;         /* Extent of individuals_table        */
 368
 369 /* ------------------------------------------------------------------------- */
 370 /*   Arrays used by this file                                                */
 371 /* ------------------------------------------------------------------------- */
 372
 373 objecttz     *objectsz;                /* Z-code only                        */
 374 objecttg     *objectsg;                /* Glulx only                         */
 375 uchar        *objectatts;              /* Glulx only                         */
 376 static int   *classes_to_inherit_from;
 377 int          *class_object_numbers;
 378 int32        *class_begins_at;
 379
 380
 381 /* ------------------------------------------------------------------------- */
 382 /*   Tracing for compiler maintenance                                        */
 383 /* ------------------------------------------------------------------------- */
 384
 385 extern void list_object_tree(void)
 386 {   int i;
 387     printf("obj   par nxt chl   Object tree:\n");
 388     for (i=0; i<no_objects; i++)
 389         printf("%3d   %3d %3d %3d\n",
 390             i+1,objectsz[i].parent,objectsz[i].next, objectsz[i].child);
 391 }
 392
 393 /* ------------------------------------------------------------------------- */
 394 /*   Object and class manufacture begins here.                               */
 395 /*                                                                           */
 396 /*   These definitions have headers (parsed far, far below) and a series     */
 397 /*   of segments, introduced by keywords and optionally separated by commas. */
 398 /*   Each segment has its own parsing routine.  Note that when errors are    */
 399 /*   detected, parsing continues rather than being abandoned, which assists  */
 400 /*   a little in "error recovery" (i.e. in stopping lots more errors being   */
 401 /*   produced for essentially the same mistake).                             */
 402 /* ------------------------------------------------------------------------- */
 403
 404 /* ========================================================================= */
 405 /*   [1]  The object-maker: builds an object from a specification, viz.:     */
 406 /*                                                                           */
 407 /*           full_object,                                                    */
 408 /*           shortname_buffer,                                               */
 409 /*           parent_of_this_obj,                                             */
 410 /*           current_defn_is_class (flag)                                    */
 411 /*           classes_to_inherit_from[], no_classes_to_inherit_from,          */
 412 /*           individual_prop_table_size (to date  )                          */
 413 /*                                                                           */
 414 /*   For efficiency's sake, the individual properties table has already been */
 415 /*   created (as far as possible, i.e., all except for inherited individual  */
 416 /*   properties); unless the flag is clear, in which case the actual         */
 417 /*   definition did not specify any individual properties.                   */
 418 /* ========================================================================= */
 419 /*   Property inheritance from classes.                                      */
 420 /* ------------------------------------------------------------------------- */
 421
 422 static void property_inheritance_z(void)
 423 {
 424     /*  Apply the property inheritance rules to full_object, which should
 425         initially be complete (i.e., this routine takes place after the whole
 426         Nearby/Object/Class definition has been parsed through).
 427
 428         On exit, full_object contains the final state of the properties to
 429         be written.                                                          */
 430
 431     int i, j, k, kmax, class, mark,
 432         prop_number, prop_length, prop_in_current_defn;
 433     uchar *class_prop_block;
 434
 435     ASSERT_ZCODE();
 436
 437     for (class=0; class<no_classes_to_inherit_from; class++)
 438     {
 439         j=0;
 440         mark = class_begins_at[classes_to_inherit_from[class]-1];
 441         class_prop_block = (uchar *) (properties_table + mark);
 442
 443         while (class_prop_block[j]!=0)
 444         {   if (version_number == 3)
 445             {   prop_number = class_prop_block[j]%32;
 446                 prop_length = 1 + class_prop_block[j++]/32;
 447             }
 448             else
 449             {   prop_number = class_prop_block[j]%64;
 450                 prop_length = 1 + class_prop_block[j++]/64;
 451                 if (prop_length > 2)
 452                     prop_length = class_prop_block[j++]%64;
 453             }
 454
 455             /*  So we now have property number prop_number present in the
 456                 property block for the class being read: its bytes are
 457
 458                 class_prop_block[j, ..., j + prop_length - 1]
 459
 460                 Question now is: is there already a value given in the
 461                 current definition under this property name?                 */
 462
 463             prop_in_current_defn = FALSE;
 464
 465             kmax = full_object.l;
 466
 467             for (k=0; k<kmax; k++)
 468                 if (full_object.pp[k].num == prop_number)
 469                 {   prop_in_current_defn = TRUE;
 470
 471                     /*  (Note that the built-in "name" property is additive) */
 472
 473                     if ((prop_number==1) || (prop_is_additive[prop_number]))
 474                     {
 475                         /*  The additive case: we accumulate the class
 476                             property values onto the end of the full_object
 477                             property                                         */
 478
 479                         for (i=full_object.pp[k].l;
 480                              i<full_object.pp[k].l+prop_length/2; i++)
 481                         {   if (i >= 32)
 482                             {   error("An additive property has inherited \
 483 so many values that the list has overflowed the maximum 32 entries");
 484                                 break;
 485                             }
 486                             full_object.pp[k].ao[i].value = mark + j;
 487                             j += 2;
 488                             full_object.pp[k].ao[i].marker = INHERIT_MV;
 489                             full_object.pp[k].ao[i].type = LONG_CONSTANT_OT;
 490                         }
 491                         full_object.pp[k].l += prop_length/2;
 492                     }
 493                     else
 494                         /*  The ordinary case: the full_object property
 495                             values simply overrides the class definition,
 496                             so we skip over the values in the class table    */
 497
 498                         j+=prop_length;
 499
 500                     if (prop_number==3)
 501                     {   int y, z, class_block_offset;
 502                         uchar *p;
 503
 504                         /*  Property 3 holds the address of the table of
 505                             instance variables, so this is the case where
 506                             the object already has instance variables in its
 507                             own table but must inherit some more from the
 508                             class  */
 509
 510                         class_block_offset = class_prop_block[j-2]*256
 511                                              + class_prop_block[j-1];
 512
 513                         p = individuals_table + class_block_offset;
 514                         z = class_block_offset;
 515                         while ((p[0]!=0)||(p[1]!=0))
 516                         {   int already_present = FALSE, l;
 517                             for (l = full_object.pp[k].ao[0].value; l < i_m;
 518                                  l = l + 3 + individuals_table[l + 2])
 519                                 if (individuals_table[l] == p[0]
 520                                     && individuals_table[l + 1] == p[1])
 521                                 {   already_present = TRUE; break;
 522                                 }
 523                             if (already_present == FALSE)
 524                             {   if (module_switch)
 525                                     backpatch_zmachine(IDENT_MV,
 526                                         INDIVIDUAL_PROP_ZA, i_m);
 527                                 if (i_m+3+p[2] > MAX_INDIV_PROP_TABLE_SIZE)
 528                                     memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
 529                                         MAX_INDIV_PROP_TABLE_SIZE);
 530                                 individuals_table[i_m++] = p[0];
 531                                 individuals_table[i_m++] = p[1];
 532                                 individuals_table[i_m++] = p[2];
 533                                 for (y=0;y < p[2]/2;y++)
 534                                 {   individuals_table[i_m++] = (z+3+y*2)/256;
 535                                     individuals_table[i_m++] = (z+3+y*2)%256;
 536                                     backpatch_zmachine(INHERIT_INDIV_MV,
 537                                         INDIVIDUAL_PROP_ZA, i_m-2);
 538                                 }
 539                             }
 540                             z += p[2] + 3;
 541                             p += p[2] + 3;
 542                         }
 543                         individuals_length = i_m;
 544                     }
 545
 546                     /*  For efficiency we exit the loop now (this property
 547                         number has been dealt with)                          */
 548
 549                     break;
 550                 }
 551
 552             if (!prop_in_current_defn)
 553             {
 554                 /*  The case where the class defined a property which wasn't
 555                     defined at all in full_object: we copy out the data into
 556                     a new property added to full_object                      */
 557
 558                 k=full_object.l++;
 559                 full_object.pp[k].num = prop_number;
 560                 full_object.pp[k].l = prop_length/2;
 561                 for (i=0; i<prop_length/2; i++)
 562                 {   full_object.pp[k].ao[i].value = mark + j;
 563                     j+=2;
 564                     full_object.pp[k].ao[i].marker = INHERIT_MV;
 565                     full_object.pp[k].ao[i].type = LONG_CONSTANT_OT;
 566                 }
 567
 568                 if (prop_number==3)
 569                 {   int y, z, class_block_offset;
 570                     uchar *p;
 571
 572                     /*  Property 3 holds the address of the table of
 573                         instance variables, so this is the case where
 574                         the object had no instance variables of its own
 575                         but must inherit some more from the class  */
 576
 577                     if (individual_prop_table_size++ == 0)
 578                     {   full_object.pp[k].num = 3;
 579                         full_object.pp[k].l = 1;
 580                         full_object.pp[k].ao[0].value
 581                             = individuals_length;
 582                         full_object.pp[k].ao[0].marker = INDIVPT_MV;
 583                         full_object.pp[k].ao[0].type = LONG_CONSTANT_OT;
 584                         i_m = individuals_length;
 585                     }
 586                     class_block_offset = class_prop_block[j-2]*256
 587                                          + class_prop_block[j-1];
 588
 589                     p = individuals_table + class_block_offset;
 590                     z = class_block_offset;
 591                     while ((p[0]!=0)||(p[1]!=0))
 592                     {   if (module_switch)
 593                         backpatch_zmachine(IDENT_MV, INDIVIDUAL_PROP_ZA, i_m);
 594                         if (i_m+3+p[2] > MAX_INDIV_PROP_TABLE_SIZE)
 595                             memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
 596                                 MAX_INDIV_PROP_TABLE_SIZE);
 597                         individuals_table[i_m++] = p[0];
 598                         individuals_table[i_m++] = p[1];
 599                         individuals_table[i_m++] = p[2];
 600                         for (y=0;y < p[2]/2;y++)
 601                         {   individuals_table[i_m++] = (z+3+y*2)/256;
 602                             individuals_table[i_m++] = (z+3+y*2)%256;
 603                             backpatch_zmachine(INHERIT_INDIV_MV,
 604                                 INDIVIDUAL_PROP_ZA, i_m-2);
 605                         }
 606                         z += p[2] + 3;
 607                         p += p[2] + 3;
 608                     }
 609                     individuals_length = i_m;
 610                 }
 611             }
 612         }
 613     }
 614
 615     if (individual_prop_table_size > 0)
 616     {
 617         if (i_m+2 > MAX_INDIV_PROP_TABLE_SIZE)
 618             memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
 619                 MAX_INDIV_PROP_TABLE_SIZE);
 620
 621         individuals_table[i_m++] = 0;
 622         individuals_table[i_m++] = 0;
 623         individuals_length += 2;
 624     }
 625 }
 626
 627 static void property_inheritance_g(void)
 628 {
 629   /*  Apply the property inheritance rules to full_object, which should
 630       initially be complete (i.e., this routine takes place after the whole
 631       Nearby/Object/Class definition has been parsed through).
 632
 633       On exit, full_object contains the final state of the properties to
 634       be written. */
 635
 636   int i, j, k, class, num_props,
 637     prop_number, prop_length, prop_flags, prop_in_current_defn;
 638   int32 mark, prop_addr;
 639   uchar *cpb, *pe;
 640
 641   ASSERT_GLULX();
 642
 643   for (class=0; class<no_classes_to_inherit_from; class++) {
 644     mark = class_begins_at[classes_to_inherit_from[class]-1];
 645     cpb = (uchar *) (properties_table + mark);
 646     /* This now points to the compiled property-table for the class.
 647        We'll have to go through and decompile it. (For our sins.) */
 648     num_props = ReadInt32(cpb);
 649     for (j=0; j<num_props; j++) {
 650       pe = cpb + 4 + j*10;
 651       prop_number = ReadInt16(pe);
 652       pe += 2;
 653       prop_length = ReadInt16(pe);
 654       pe += 2;
 655       prop_addr = ReadInt32(pe);
 656       pe += 4;
 657       prop_flags = ReadInt16(pe);
 658       pe += 2;
 659
 660       /*  So we now have property number prop_number present in the
 661           property block for the class being read. Its bytes are
 662           cpb[prop_addr ... prop_addr + prop_length - 1]
 663           Question now is: is there already a value given in the
 664           current definition under this property name? */
 665
 666       prop_in_current_defn = FALSE;
 667
 668       for (k=0; k<full_object_g.numprops; k++) {
 669         if (full_object_g.props[k].num == prop_number) {
 670           prop_in_current_defn = TRUE;
 671           break;
 672         }
 673       }
 674
 675       if (prop_in_current_defn) {
 676         if ((prop_number==1)
 677           || (prop_number < INDIV_PROP_START
 678             && prop_is_additive[prop_number])) {
 679           /*  The additive case: we accumulate the class
 680               property values onto the end of the full_object
 681               properties. Remember that k is still the index number
 682               of the first prop-block matching our property number. */
 683           int prevcont;
 684           if (full_object_g.props[k].continuation == 0) {
 685             full_object_g.props[k].continuation = 1;
 686             prevcont = 1;
 687           }
 688           else {
 689             prevcont = full_object_g.props[k].continuation;
 690             for (k++; k<full_object_g.numprops; k++) {
 691               if (full_object_g.props[k].num == prop_number) {
 692                 prevcont = full_object_g.props[k].continuation;
 693               }
 694             }
 695           }
 696           k = full_object_g.numprops++;
 697           full_object_g.props[k].num = prop_number;
 698           full_object_g.props[k].flags = 0;
 699           full_object_g.props[k].datastart = full_object_g.propdatasize;
 700           full_object_g.props[k].continuation = prevcont+1;
 701           full_object_g.props[k].datalen = prop_length;
 702           if (full_object_g.propdatasize + prop_length
 703             > MAX_OBJ_PROP_TABLE_SIZE) {
 704             memoryerror("MAX_OBJ_PROP_TABLE_SIZE",MAX_OBJ_PROP_TABLE_SIZE);
 705           }
 706
 707           for (i=0; i<prop_length; i++) {
 708             int ppos = full_object_g.propdatasize++;
 709             full_object_g.propdata[ppos].value = prop_addr + 4*i;
 710             full_object_g.propdata[ppos].marker = INHERIT_MV;
 711             full_object_g.propdata[ppos].type = CONSTANT_OT;
 712           }
 713         }
 714         else {
 715           /*  The ordinary case: the full_object_g property
 716               values simply overrides the class definition,
 717               so we skip over the values in the class table. */
 718         }
 719       }
 720           else {
 721             /*  The case where the class defined a property which wasn't
 722                 defined at all in full_object_g: we copy out the data into
 723                 a new property added to full_object_g. */
 724             k = full_object_g.numprops++;
 725             full_object_g.props[k].num = prop_number;
 726             full_object_g.props[k].flags = prop_flags;
 727             full_object_g.props[k].datastart = full_object_g.propdatasize;
 728             full_object_g.props[k].continuation = 0;
 729             full_object_g.props[k].datalen = prop_length;
 730             if (full_object_g.propdatasize + prop_length
 731               > MAX_OBJ_PROP_TABLE_SIZE) {
 732               memoryerror("MAX_OBJ_PROP_TABLE_SIZE",MAX_OBJ_PROP_TABLE_SIZE);
 733             }
 734
 735             for (i=0; i<prop_length; i++) {
 736               int ppos = full_object_g.propdatasize++;
 737               full_object_g.propdata[ppos].value = prop_addr + 4*i;
 738               full_object_g.propdata[ppos].marker = INHERIT_MV;
 739               full_object_g.propdata[ppos].type = CONSTANT_OT;
 740             }
 741           }
 742
 743           if (full_object_g.numprops == MAX_OBJ_PROP_COUNT) {
 744             memoryerror("MAX_OBJ_PROP_COUNT",MAX_OBJ_PROP_COUNT);
 745           }
 746     }
 747   }
 748
 749 }
 750
 751 /* ------------------------------------------------------------------------- */
 752 /*   Construction of Z-machine-format property blocks.                       */
 753 /* ------------------------------------------------------------------------- */
 754
 755 static int write_properties_between(uchar *p, int mark, int from, int to)
 756 {   int j, k, prop_number, prop_length;
 757     /* Note that p is properties_table. */
 758     for (prop_number=to; prop_number>=from; prop_number--)
 759     {   for (j=0; j<full_object.l; j++)
 760         {   if ((full_object.pp[j].num == prop_number)
 761                 && (full_object.pp[j].l != 100))
 762             {   prop_length = 2*full_object.pp[j].l;
 763                 if (mark+2+prop_length >= MAX_PROP_TABLE_SIZE)
 764                     memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
 765                 if (version_number == 3)
 766                     p[mark++] = prop_number + (prop_length - 1)*32;
 767                 else
 768                 {   switch(prop_length)
 769                     {   case 1:
 770                           p[mark++] = prop_number; break;
 771                         case 2:
 772                           p[mark++] = prop_number + 0x40; break;
 773                         default:
 774                           p[mark++] = prop_number + 0x80;
 775                           p[mark++] = prop_length + 0x80; break;
 776                     }
 777                 }
 778
 779                 for (k=0; k<full_object.pp[j].l; k++)
 780                 {   if (full_object.pp[j].ao[k].marker != 0)
 781                         backpatch_zmachine(full_object.pp[j].ao[k].marker,
 782                             PROP_ZA, mark);
 783                     p[mark++] = full_object.pp[j].ao[k].value/256;
 784                     p[mark++] = full_object.pp[j].ao[k].value%256;
 785                 }
 786             }
 787         }
 788     }
 789
 790     p[mark++]=0;
 791     return(mark);
 792 }
 793
 794 static int write_property_block_z(char *shortname)
 795 {
 796     /*  Compile the (now complete) full_object properties into a
 797         property-table block at "p" in Inform's memory.
 798         "shortname" is the object's short name, if specified; otherwise
 799         NULL.
 800
 801         Return the number of bytes written to the block.                     */
 802
 803     int32 mark = properties_table_size, i;
 804     uchar *p = (uchar *) properties_table;
 805
 806     /* printf("Object at %04x\n", mark); */
 807
 808     if (shortname != NULL)
 809     {   uchar *tmp;
 810         if (mark+1+510 >= MAX_PROP_TABLE_SIZE)
 811             memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
 812         tmp = translate_text(p+mark+1,p+mark+1+510,shortname,STRCTX_OBJNAME);
 813         if (!tmp) error ("Short name of object exceeded 765 Z-characters");
 814         i = subtract_pointers(tmp,(p+mark+1));
 815         p[mark] = i/2;
 816         mark += i+1;
 817     }
 818     if (current_defn_is_class)
 819     {   mark = write_properties_between(p,mark,3,3);
 820         for (i=0;i<6;i++)
 821             p[mark++] = full_object.atts[i];
 822         class_begins_at[no_classes++] = mark;
 823     }
 824
 825     mark = write_properties_between(p, mark, 1, (version_number==3)?31:63);
 826
 827     i = mark - properties_table_size;
 828     properties_table_size = mark;
 829
 830     return(i);
 831 }
 832
 833 static int gpropsort(void *ptr1, void *ptr2)
 834 {
 835   propg *prop1 = ptr1;
 836   propg *prop2 = ptr2;
 837
 838   if (prop2->num == -1)
 839     return -1;
 840   if (prop1->num == -1)
 841     return 1;
 842   if (prop1->num < prop2->num)
 843     return -1;
 844   if (prop1->num > prop2->num)
 845     return 1;
 846
 847   return (prop1->continuation - prop2->continuation);
 848 }
 849
 850 static int32 write_property_block_g(void)
 851 {
 852   /*  Compile the (now complete) full_object properties into a
 853       property-table block at "p" in Inform's memory.
 854       Return the number of bytes written to the block.
 855       In Glulx, the shortname property isn't used here; it's already
 856       been compiled into an ordinary string. */
 857
 858   int32 i;
 859   int ix, jx, kx, totalprops;
 860   int32 mark = properties_table_size;
 861   int32 datamark;
 862   uchar *p = (uchar *) properties_table;
 863
 864   if (current_defn_is_class) {
 865     for (i=0;i<NUM_ATTR_BYTES;i++)
 866       p[mark++] = full_object_g.atts[i];
 867     class_begins_at[no_classes++] = mark;
 868   }
 869
 870   qsort(full_object_g.props, full_object_g.numprops, sizeof(propg),
 871     (int (*)(const void *, const void *))(&gpropsort));
 872
 873   full_object_g.finalpropaddr = mark;
 874
 875   totalprops = 0;
 876
 877   for (ix=0; ix<full_object_g.numprops; ix=jx) {
 878     int propnum = full_object_g.props[ix].num;
 879     if (propnum == -1)
 880         break;
 881     for (jx=ix;
 882         jx<full_object_g.numprops && full_object_g.props[jx].num == propnum;
 883         jx++);
 884     totalprops++;
 885   }
 886
 887   /* Write out the number of properties in this table. */
 888   if (mark+4 >= MAX_PROP_TABLE_SIZE)
 889       memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
 890   WriteInt32(p+mark, totalprops);
 891   mark += 4;
 892
 893   datamark = mark + 10*totalprops;
 894
 895   for (ix=0; ix<full_object_g.numprops; ix=jx) {
 896     int propnum = full_object_g.props[ix].num;
 897     int flags = full_object_g.props[ix].flags;
 898     int totallen = 0;
 899     int32 datamarkstart = datamark;
 900     if (propnum == -1)
 901       break;
 902     for (jx=ix;
 903         jx<full_object_g.numprops && full_object_g.props[jx].num == propnum;
 904         jx++) {
 905       int32 datastart = full_object_g.props[jx].datastart;
 906       if (datamark+4*full_object_g.props[jx].datalen >= MAX_PROP_TABLE_SIZE)
 907         memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
 908       for (kx=0; kx<full_object_g.props[jx].datalen; kx++) {
 909         int32 val = full_object_g.propdata[datastart+kx].value;
 910         WriteInt32(p+datamark, val);
 911         if (full_object_g.propdata[datastart+kx].marker != 0)
 912           backpatch_zmachine(full_object_g.propdata[datastart+kx].marker,
 913             PROP_ZA, datamark);
 914         totallen++;
 915         datamark += 4;
 916       }
 917     }
 918     if (mark+10 >= MAX_PROP_TABLE_SIZE)
 919         memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
 920     WriteInt16(p+mark, propnum);
 921     mark += 2;
 922     WriteInt16(p+mark, totallen);
 923     mark += 2;
 924     WriteInt32(p+mark, datamarkstart);
 925     mark += 4;
 926     WriteInt16(p+mark, flags);
 927     mark += 2;
 928   }
 929
 930   mark = datamark;
 931
 932   i = mark - properties_table_size;
 933   properties_table_size = mark;
 934   return i;
 935 }
 936
 937 /* ------------------------------------------------------------------------- */
 938 /*   The final stage in Nearby/Object/Class definition processing.           */
 939 /* ------------------------------------------------------------------------- */
 940
 941 static void manufacture_object_z(void)
 942 {   int i, j;
 943
 944     segment_markers.enabled = FALSE;
 945     directives.enabled = TRUE;
 946
 947     property_inheritance_z();
 948
 949     objectsz[no_objects].parent = parent_of_this_obj;
 950     objectsz[no_objects].next = 0;
 951     objectsz[no_objects].child = 0;
 952
 953     if ((parent_of_this_obj > 0) && (parent_of_this_obj != 0x7fff))
 954     {   i = objectsz[parent_of_this_obj-1].child;
 955         if (i == 0)
 956             objectsz[parent_of_this_obj-1].child = no_objects + 1;
 957         else
 958         {   while(objectsz[i-1].next != 0) i = objectsz[i-1].next;
 959             objectsz[i-1].next = no_objects+1;
 960         }
 961     }
 962
 963         /*  The properties table consists simply of a sequence of property
 964             blocks, one for each object in order of definition, exactly as
 965             it will appear in the final Z-machine.                           */
 966
 967     j = write_property_block_z(shortname_buffer);
 968
 969     objectsz[no_objects].propsize = j;
 970     if (properties_table_size >= MAX_PROP_TABLE_SIZE)
 971         memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
 972
 973     if (current_defn_is_class)
 974         for (i=0;i<6;i++) objectsz[no_objects].atts[i] = 0;
 975     else
 976         for (i=0;i<6;i++)
 977             objectsz[no_objects].atts[i] = full_object.atts[i];
 978
 979     no_objects++;
 980 }
 981
 982 static void manufacture_object_g(void)
 983 {   int32 i, j;
 984
 985     segment_markers.enabled = FALSE;
 986     directives.enabled = TRUE;
 987
 988     property_inheritance_g();
 989
 990     objectsg[no_objects].parent = parent_of_this_obj;
 991     objectsg[no_objects].next = 0;
 992     objectsg[no_objects].child = 0;
 993
 994     if ((parent_of_this_obj > 0) && (parent_of_this_obj != 0x7fffffff))
 995     {   i = objectsg[parent_of_this_obj-1].child;
 996         if (i == 0)
 997             objectsg[parent_of_this_obj-1].child = no_objects + 1;
 998         else
 999         {   while(objectsg[i-1].next != 0) i = objectsg[i-1].next;
1000             objectsg[i-1].next = no_objects+1;
1001         }
1002     }
1003
1004     objectsg[no_objects].shortname = compile_string(shortname_buffer,
1005       STRCTX_OBJNAME);
1006
1007         /*  The properties table consists simply of a sequence of property
1008             blocks, one for each object in order of definition, exactly as
1009             it will appear in the final machine image.                      */
1010
1011     j = write_property_block_g();
1012
1013     objectsg[no_objects].propaddr = full_object_g.finalpropaddr;
1014
1015     objectsg[no_objects].propsize = j;
1016     if (properties_table_size >= MAX_PROP_TABLE_SIZE)
1017         memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
1018
1019     if (current_defn_is_class)
1020         for (i=0;i<NUM_ATTR_BYTES;i++)
1021             objectatts[no_objects*NUM_ATTR_BYTES+i] = 0;
1022     else
1023         for (i=0;i<NUM_ATTR_BYTES;i++)
1024             objectatts[no_objects*NUM_ATTR_BYTES+i] = full_object_g.atts[i];
1025
1026     no_objects++;
1027 }
1028
1029
1030 /* ========================================================================= */
1031 /*   [2]  The Object/Nearby/Class directives parser: translating the syntax  */
1032 /*        into object specifications and then triggering off the above.      */
1033 /* ========================================================================= */
1034 /*   Properties ("with" or "private") segment.                               */
1035 /* ------------------------------------------------------------------------- */
1036
1037 static int *defined_this_segment;
1038 static long defined_this_segment_size; /* calloc size */
1039 static int def_t_s;
1040
1041 static void ensure_defined_this_segment(int newsize)
1042 {
1043     int oldsize = defined_this_segment_size;
1044     defined_this_segment_size = newsize;
1045     my_recalloc(&defined_this_segment, sizeof(int), oldsize,
1046         defined_this_segment_size, "defined this segment table");
1047 }
1048
1049 static void properties_segment_z(int this_segment)
1050 {
1051     /*  Parse through the "with" part of an object/class definition:
1052
1053         <prop-1> <values...>, <prop-2> <values...>, ..., <prop-n> <values...>
1054
1055         This routine also handles "private", with this_segment being equal
1056         to the token value for the introductory word ("private" or "with").  */
1057
1058
1059     int   i, property_name_symbol, property_number=0, next_prop=0, length,
1060           individual_property, this_identifier_number;
1061
1062     do
1063     {   get_next_token_with_directives();
1064         if ((token_type == SEGMENT_MARKER_TT)
1065             || (token_type == EOF_TT)
1066             || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
1067         {   put_token_back(); return;
1068         }
1069
1070         if (token_type != SYMBOL_TT)
1071         {   ebf_error("property name", token_text);
1072             return;
1073         }
1074
1075         individual_property = (stypes[token_value] != PROPERTY_T);
1076
1077         if (individual_property)
1078         {   if (sflags[token_value] & UNKNOWN_SFLAG)
1079             {   this_identifier_number = no_individual_properties++;
1080                 assign_symbol(token_value, this_identifier_number,
1081                     INDIVIDUAL_PROPERTY_T);
1082
1083                 if (debugfile_switch)
1084                 {   debug_file_printf("<property>");
1085                     debug_file_printf
1086                         ("<identifier>%s</identifier>", token_text);
1087                     debug_file_printf
1088                         ("<value>%d</value>", this_identifier_number);
1089                     debug_file_printf("</property>");
1090                 }
1091
1092             }
1093             else
1094             {   if (stypes[token_value]==INDIVIDUAL_PROPERTY_T)
1095                     this_identifier_number = svals[token_value];
1096                 else
1097                 {   ebf_symbol_error("property name", token_text, typename(stypes[token_value]), slines[token_value]);
1098                     return;
1099                 }
1100             }
1101
1102             if (def_t_s >= defined_this_segment_size)
1103                 ensure_defined_this_segment(def_t_s*2);
1104             defined_this_segment[def_t_s++] = token_value;
1105
1106             if (individual_prop_table_size++ == 0)
1107             {   full_object.pp[full_object.l].num = 3;
1108                 full_object.pp[full_object.l].l = 1;
1109                 full_object.pp[full_object.l].ao[0].value
1110                     = individuals_length;
1111                 full_object.pp[full_object.l].ao[0].type = LONG_CONSTANT_OT;
1112                 full_object.pp[full_object.l].ao[0].marker = INDIVPT_MV;
1113
1114                 i_m = individuals_length;
1115                 full_object.l++;
1116             }
1117             individuals_table[i_m] = this_identifier_number/256;
1118             if (this_segment == PRIVATE_SEGMENT)
1119                 individuals_table[i_m] |= 0x80;
1120             individuals_table[i_m+1] = this_identifier_number%256;
1121             if (module_switch)
1122                 backpatch_zmachine(IDENT_MV, INDIVIDUAL_PROP_ZA, i_m);
1123             individuals_table[i_m+2] = 0;
1124         }
1125         else
1126         {   if (sflags[token_value] & UNKNOWN_SFLAG)
1127             {   error_named("No such property name as", token_text);
1128                 return;
1129             }
1130             if (this_segment == PRIVATE_SEGMENT)
1131                 error_named("Property should be declared in 'with', \
1132 not 'private':", token_text);
1133             if (def_t_s >= defined_this_segment_size)
1134                 ensure_defined_this_segment(def_t_s*2);
1135             defined_this_segment[def_t_s++] = token_value;
1136             property_number = svals[token_value];
1137
1138             next_prop=full_object.l++;
1139             full_object.pp[next_prop].num = property_number;
1140         }
1141
1142         for (i=0; i<(def_t_s-1); i++)
1143             if (defined_this_segment[i] == token_value)
1144             {   error_named("Property given twice in the same declaration:",
1145                     (char *) symbs[token_value]);
1146             }
1147             else
1148             if (svals[defined_this_segment[i]] == svals[token_value])
1149             {   char error_b[128];
1150                 sprintf(error_b,
1151                     "Property given twice in the same declaration, because \
1152 the names '%s' and '%s' actually refer to the same property",
1153                     (char *) symbs[defined_this_segment[i]],
1154                     (char *) symbs[token_value]);
1155                 error(error_b);
1156             }
1157
1158         property_name_symbol = token_value;
1159         sflags[token_value] |= USED_SFLAG;
1160
1161         length=0;
1162         do
1163         {   assembly_operand AO;
1164             get_next_token_with_directives();
1165             if ((token_type == EOF_TT)
1166                 || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP))
1167                 || ((token_type == SEP_TT) && (token_value == COMMA_SEP)))
1168                 break;
1169
1170             if (token_type == SEGMENT_MARKER_TT) { put_token_back(); break; }
1171
1172             if ((!individual_property) && (property_number==1)
1173                 && ((token_type != SQ_TT) || (strlen(token_text) <2 ))
1174                 && (token_type != DQ_TT)
1175                 )
1176                 warning ("'name' property should only contain dictionary words");
1177
1178             if ((token_type == SEP_TT) && (token_value == OPEN_SQUARE_SEP))
1179             {   char embedded_name[80];
1180                 if (current_defn_is_class)
1181                 {   sprintf(embedded_name,
1182                         "%s::%s", classname_text,
1183                         (char *) symbs[property_name_symbol]);
1184                 }
1185                 else
1186                 {   sprintf(embedded_name,
1187                         "%s.%s", objectname_text,
1188                         (char *) symbs[property_name_symbol]);
1189                 }
1190                 AO.value = parse_routine(NULL, TRUE, embedded_name, FALSE, -1);
1191                 AO.type = LONG_CONSTANT_OT;
1192                 AO.marker = IROUTINE_MV;
1193
1194                 directives.enabled = FALSE;
1195                 segment_markers.enabled = TRUE;
1196
1197                 statements.enabled = FALSE;
1198                 misc_keywords.enabled = FALSE;
1199                 local_variables.enabled = FALSE;
1200                 system_functions.enabled = FALSE;
1201                 conditions.enabled = FALSE;
1202             }
1203             else
1204
1205             /*  A special rule applies to values in double-quotes of the
1206                 built-in property "name", which always has number 1: such
1207                 property values are dictionary entries and not static
1208                 strings                                                      */
1209
1210             if ((!individual_property) &&
1211                 (property_number==1) && (token_type == DQ_TT))
1212             {   AO.value = dictionary_add(token_text, 0x80, 0, 0);
1213                 AO.type = LONG_CONSTANT_OT;
1214                 AO.marker = DWORD_MV;
1215             }
1216             else
1217             {   if (length!=0)
1218                 {
1219                     if ((token_type == SYMBOL_TT)
1220                         && (stypes[token_value]==PROPERTY_T))
1221                     {
1222                         /*  This is not necessarily an error: it's possible
1223                             to imagine a property whose value is a list
1224                             of other properties to look up, but far more
1225                             likely that a comma has been omitted in between
1226                             two property blocks                              */
1227
1228                         warning_named(
1229                "Missing ','? Property data seems to contain the property name",
1230                             token_text);
1231                     }
1232                 }
1233
1234                 /*  An ordinary value, then:                                 */
1235
1236                 put_token_back();
1237                 AO = parse_expression(ARRAY_CONTEXT);
1238             }
1239
1240             if (length == 64)
1241             {   error_named("Limit (of 32 values) exceeded for property",
1242                     (char *) symbs[property_name_symbol]);
1243                 break;
1244             }
1245
1246             if (individual_property)
1247             {   if (AO.marker != 0)
1248                     backpatch_zmachine(AO.marker, INDIVIDUAL_PROP_ZA,
1249                         i_m+3+length);
1250                 individuals_table[i_m+3+length++] = AO.value/256;
1251                 individuals_table[i_m+3+length++] = AO.value%256;
1252             }
1253             else
1254             {   full_object.pp[next_prop].ao[length/2] = AO;
1255                 length = length + 2;
1256             }
1257
1258         } while (TRUE);
1259
1260         /*  People rarely do, but it is legal to declare a property without
1261             a value at all:
1262
1263                 with  name "fish", number, time_left;
1264
1265             in which case the properties "number" and "time_left" are
1266             created as in effect variables and initialised to zero.          */
1267
1268         if (length == 0)
1269         {   if (individual_property)
1270             {   individuals_table[i_m+3+length++] = 0;
1271                 individuals_table[i_m+3+length++] = 0;
1272             }
1273             else
1274             {   full_object.pp[next_prop].ao[0].value = 0;
1275                 full_object.pp[next_prop].ao[0].type  = LONG_CONSTANT_OT;
1276                 full_object.pp[next_prop].ao[0].marker = 0;
1277                 length = 2;
1278             }
1279         }
1280
1281         if ((version_number==3) && (!individual_property))
1282         {   if (length > 8)
1283             {
1284        warning_named("Version 3 limit of 4 values per property exceeded \
1285 (use -v5 to get 32), so truncating property",
1286                     (char *) symbs[property_name_symbol]);
1287                 length = 8;
1288             }
1289         }
1290
1291         if (individual_property)
1292         {
1293             if (individuals_length+length+3 > MAX_INDIV_PROP_TABLE_SIZE)
1294                 memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
1295                     MAX_INDIV_PROP_TABLE_SIZE);
1296             individuals_table[i_m + 2] = length;
1297             individuals_length += length+3;
1298             i_m = individuals_length;
1299         }
1300         else
1301             full_object.pp[next_prop].l = length/2;
1302
1303         if ((token_type == EOF_TT)
1304             || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
1305         {   put_token_back(); return;
1306         }
1307
1308     } while (TRUE);
1309 }
1310
1311
1312 static void properties_segment_g(int this_segment)
1313 {
1314     /*  Parse through the "with" part of an object/class definition:
1315
1316         <prop-1> <values...>, <prop-2> <values...>, ..., <prop-n> <values...>
1317
1318         This routine also handles "private", with this_segment being equal
1319         to the token value for the introductory word ("private" or "with").  */
1320
1321
1322     int   i, next_prop,
1323           individual_property, this_identifier_number;
1324     int32 property_name_symbol, property_number, length;
1325
1326     do
1327     {   get_next_token_with_directives();
1328         if ((token_type == SEGMENT_MARKER_TT)
1329             || (token_type == EOF_TT)
1330             || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
1331         {   put_token_back(); return;
1332         }
1333
1334         if (token_type != SYMBOL_TT)
1335         {   ebf_error("property name", token_text);
1336             return;
1337         }
1338
1339         individual_property = (stypes[token_value] != PROPERTY_T);
1340
1341         if (individual_property)
1342         {   if (sflags[token_value] & UNKNOWN_SFLAG)
1343             {   this_identifier_number = no_individual_properties++;
1344                 assign_symbol(token_value, this_identifier_number,
1345                     INDIVIDUAL_PROPERTY_T);
1346
1347                 if (debugfile_switch)
1348                 {   debug_file_printf("<property>");
1349                     debug_file_printf
1350                         ("<identifier>%s</identifier>", token_text);
1351                     debug_file_printf
1352                         ("<value>%d</value>", this_identifier_number);
1353                     debug_file_printf("</property>");
1354                 }
1355
1356             }
1357             else
1358             {   if (stypes[token_value]==INDIVIDUAL_PROPERTY_T)
1359                     this_identifier_number = svals[token_value];
1360                 else
1361                 {   ebf_symbol_error("property name", token_text, typename(stypes[token_value]), slines[token_value]);
1362                     return;
1363                 }
1364             }
1365
1366             if (def_t_s >= defined_this_segment_size)
1367                 ensure_defined_this_segment(def_t_s*2);
1368             defined_this_segment[def_t_s++] = token_value;
1369             property_number = svals[token_value];
1370
1371             next_prop=full_object_g.numprops++;
1372             full_object_g.props[next_prop].num = property_number;
1373             full_object_g.props[next_prop].flags =
1374               ((this_segment == PRIVATE_SEGMENT) ? 1 : 0);
1375             full_object_g.props[next_prop].datastart = full_object_g.propdatasize;
1376             full_object_g.props[next_prop].continuation = 0;
1377             full_object_g.props[next_prop].datalen = 0;
1378         }
1379         else
1380         {   if (sflags[token_value] & UNKNOWN_SFLAG)
1381             {   error_named("No such property name as", token_text);
1382                 return;
1383             }
1384             if (this_segment == PRIVATE_SEGMENT)
1385                 error_named("Property should be declared in 'with', \
1386 not 'private':", token_text);
1387
1388             if (def_t_s >= defined_this_segment_size)
1389                 ensure_defined_this_segment(def_t_s*2);
1390             defined_this_segment[def_t_s++] = token_value;
1391             property_number = svals[token_value];
1392
1393             next_prop=full_object_g.numprops++;
1394             full_object_g.props[next_prop].num = property_number;
1395             full_object_g.props[next_prop].flags = 0;
1396             full_object_g.props[next_prop].datastart = full_object_g.propdatasize;
1397             full_object_g.props[next_prop].continuation = 0;
1398             full_object_g.props[next_prop].datalen = 0;
1399         }
1400
1401         for (i=0; i<(def_t_s-1); i++)
1402             if (defined_this_segment[i] == token_value)
1403             {   error_named("Property given twice in the same declaration:",
1404                     (char *) symbs[token_value]);
1405             }
1406             else
1407             if (svals[defined_this_segment[i]] == svals[token_value])
1408             {   char error_b[128];
1409                 sprintf(error_b,
1410                     "Property given twice in the same declaration, because \
1411 the names '%s' and '%s' actually refer to the same property",
1412                     (char *) symbs[defined_this_segment[i]],
1413                     (char *) symbs[token_value]);
1414                 error(error_b);
1415             }
1416
1417         if (full_object_g.numprops == MAX_OBJ_PROP_COUNT) {
1418           memoryerror("MAX_OBJ_PROP_COUNT",MAX_OBJ_PROP_COUNT);
1419         }
1420
1421         property_name_symbol = token_value;
1422         sflags[token_value] |= USED_SFLAG;
1423
1424         length=0;
1425         do
1426         {   assembly_operand AO;
1427             get_next_token_with_directives();
1428             if ((token_type == EOF_TT)
1429                 || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP))
1430                 || ((token_type == SEP_TT) && (token_value == COMMA_SEP)))
1431                 break;
1432
1433             if (token_type == SEGMENT_MARKER_TT) { put_token_back(); break; }
1434
1435             if ((!individual_property) && (property_number==1)
1436                 && ((token_type != SQ_TT) || (strlen(token_text) <2 ))
1437                 && (token_type != DQ_TT)
1438                 )
1439                 warning ("'name' property should only contain dictionary words");
1440
1441             if ((token_type == SEP_TT) && (token_value == OPEN_SQUARE_SEP))
1442             {   char embedded_name[80];
1443                 if (current_defn_is_class)
1444                 {   sprintf(embedded_name,
1445                         "%s::%s", classname_text,
1446                         (char *) symbs[property_name_symbol]);
1447                 }
1448                 else
1449                 {   sprintf(embedded_name,
1450                         "%s.%s", objectname_text,
1451                         (char *) symbs[property_name_symbol]);
1452                 }
1453                 AO.value = parse_routine(NULL, TRUE, embedded_name, FALSE, -1);
1454                 AO.type = CONSTANT_OT;
1455                 AO.marker = IROUTINE_MV;
1456
1457                 directives.enabled = FALSE;
1458                 segment_markers.enabled = TRUE;
1459
1460                 statements.enabled = FALSE;
1461                 misc_keywords.enabled = FALSE;
1462                 local_variables.enabled = FALSE;
1463                 system_functions.enabled = FALSE;
1464                 conditions.enabled = FALSE;
1465             }
1466             else
1467
1468             /*  A special rule applies to values in double-quotes of the
1469                 built-in property "name", which always has number 1: such
1470                 property values are dictionary entries and not static
1471                 strings                                                      */
1472
1473             if ((!individual_property) &&
1474                 (property_number==1) && (token_type == DQ_TT))
1475             {   AO.value = dictionary_add(token_text, 0x80, 0, 0);
1476                 AO.type = CONSTANT_OT;
1477                 AO.marker = DWORD_MV;
1478             }
1479             else
1480             {   if (length!=0)
1481                 {
1482                     if ((token_type == SYMBOL_TT)
1483                         && (stypes[token_value]==PROPERTY_T))
1484                     {
1485                         /*  This is not necessarily an error: it's possible
1486                             to imagine a property whose value is a list
1487                             of other properties to look up, but far more
1488                             likely that a comma has been omitted in between
1489                             two property blocks                              */
1490
1491                         warning_named(
1492                "Missing ','? Property data seems to contain the property name",
1493                             token_text);
1494                     }
1495                 }
1496
1497                 /*  An ordinary value, then:                                 */
1498
1499                 put_token_back();
1500                 AO = parse_expression(ARRAY_CONTEXT);
1501             }
1502
1503             if (length == 32768) /* VENEER_CONSTRAINT_ON_PROP_TABLE_SIZE? */
1504             {   error_named("Limit (of 32768 values) exceeded for property",
1505                     (char *) symbs[property_name_symbol]);
1506                 break;
1507             }
1508
1509             if (full_object_g.propdatasize >= MAX_OBJ_PROP_TABLE_SIZE) {
1510               memoryerror("MAX_OBJ_PROP_TABLE_SIZE",MAX_OBJ_PROP_TABLE_SIZE);
1511             }
1512
1513             full_object_g.propdata[full_object_g.propdatasize++] = AO;
1514             length += 1;
1515
1516         } while (TRUE);
1517
1518         /*  People rarely do, but it is legal to declare a property without
1519             a value at all:
1520
1521                 with  name "fish", number, time_left;
1522
1523             in which case the properties "number" and "time_left" are
1524             created as in effect variables and initialised to zero.          */
1525
1526         if (length == 0)
1527         {
1528             assembly_operand AO;
1529             AO.value = 0;
1530             AO.type = CONSTANT_OT;
1531             AO.marker = 0;
1532             full_object_g.propdata[full_object_g.propdatasize++] = AO;
1533             length += 1;
1534         }
1535
1536         full_object_g.props[next_prop].datalen = length;
1537
1538         if ((token_type == EOF_TT)
1539             || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
1540         {   put_token_back(); return;
1541         }
1542
1543     } while (TRUE);
1544 }
1545
1546 static void properties_segment(int this_segment)
1547 {
1548   if (!glulx_mode)
1549     properties_segment_z(this_segment);
1550   else
1551     properties_segment_g(this_segment);
1552 }
1553
1554 /* ------------------------------------------------------------------------- */
1555 /*   Attributes ("has") segment.                                             */
1556 /* ------------------------------------------------------------------------- */
1557
1558 static void attributes_segment(void)
1559 {
1560     /*  Parse through the "has" part of an object/class definition:
1561
1562         [~]<attribute-1> [~]<attribute-2> ... [~]<attribute-n>               */
1563
1564     int attribute_number, truth_state, bitmask;
1565     uchar *attrbyte;
1566     do
1567     {   truth_state = TRUE;
1568
1569         ParseAttrN:
1570
1571         get_next_token_with_directives();
1572         if ((token_type == SEGMENT_MARKER_TT)
1573             || (token_type == EOF_TT)
1574             || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
1575         {   if (!truth_state)
1576                 ebf_error("attribute name after '~'", token_text);
1577             put_token_back(); return;
1578         }
1579         if ((token_type == SEP_TT) && (token_value == COMMA_SEP)) return;
1580
1581         if ((token_type == SEP_TT) && (token_value == ARTNOT_SEP))
1582         {   truth_state = !truth_state; goto ParseAttrN;
1583         }
1584
1585         if ((token_type != SYMBOL_TT)
1586             || (stypes[token_value] != ATTRIBUTE_T))
1587         {   ebf_error("name of an already-declared attribute", token_text);
1588             return;
1589         }
1590
1591         attribute_number = svals[token_value];
1592         sflags[token_value] |= USED_SFLAG;
1593
1594         if (!glulx_mode) {
1595             bitmask = (1 << (7-attribute_number%8));
1596             attrbyte = &(full_object.atts[attribute_number/8]);
1597         }
1598         else {
1599             /* In Glulx, my prejudices rule, and therefore bits are numbered
1600                from least to most significant. This is the opposite of the
1601                way the Z-machine works. */
1602             bitmask = (1 << (attribute_number%8));
1603             attrbyte = &(full_object_g.atts[attribute_number/8]);
1604         }
1605
1606         if (truth_state)
1607             *attrbyte |= bitmask;     /* Set attribute bit */
1608         else
1609             *attrbyte &= ~bitmask;    /* Clear attribute bit */
1610
1611     } while (TRUE);
1612 }
1613
1614 /* ------------------------------------------------------------------------- */
1615 /*   Classes ("class") segment.                                              */
1616 /* ------------------------------------------------------------------------- */
1617
1618 static void add_class_to_inheritance_list(int class_number)
1619 {
1620     int i;
1621
1622     /*  The class number is actually the class's object number, which needs
1623         to be translated into its actual class number:                       */
1624
1625     for (i=0;i<no_classes;i++)
1626         if (class_number == class_object_numbers[i])
1627         {   class_number = i+1;
1628             break;
1629         }
1630
1631     /*  Remember the inheritance list so that property inheritance can
1632         be sorted out later on, when the definition has been finished:       */
1633
1634     classes_to_inherit_from[no_classes_to_inherit_from++] = class_number;
1635
1636     /*  Inheriting attributes from the class at once:                        */
1637
1638     if (!glulx_mode) {
1639         for (i=0; i<6; i++)
1640             full_object.atts[i]
1641                 |= properties_table[class_begins_at[class_number-1] - 6 + i];
1642     }
1643     else {
1644         for (i=0; i<NUM_ATTR_BYTES; i++)
1645             full_object_g.atts[i]
1646                 |= properties_table[class_begins_at[class_number-1]
1647                     - NUM_ATTR_BYTES + i];
1648     }
1649 }
1650
1651 static void classes_segment(void)
1652 {
1653     /*  Parse through the "class" part of an object/class definition:
1654
1655         <class-1> ... <class-n>                                              */
1656
1657     do
1658     {   get_next_token_with_directives();
1659         if ((token_type == SEGMENT_MARKER_TT)
1660             || (token_type == EOF_TT)
1661             || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
1662         {   put_token_back(); return;
1663         }
1664         if ((token_type == SEP_TT) && (token_value == COMMA_SEP)) return;
1665
1666         if ((token_type != SYMBOL_TT)
1667             || (stypes[token_value] != CLASS_T))
1668         {   ebf_error("name of an already-declared class", token_text);
1669             return;
1670         }
1671
1672         sflags[token_value] |= USED_SFLAG;
1673         add_class_to_inheritance_list(svals[token_value]);
1674     } while (TRUE);
1675 }
1676
1677 /* ------------------------------------------------------------------------- */
1678 /*   Parse the body of a Nearby/Object/Class definition.                     */
1679 /* ------------------------------------------------------------------------- */
1680
1681 static void parse_body_of_definition(void)
1682 {   int commas_in_row;
1683
1684     def_t_s = 0;
1685
1686     do
1687     {   commas_in_row = -1;
1688         do
1689         {   get_next_token_with_directives(); commas_in_row++;
1690         } while ((token_type == SEP_TT) && (token_value == COMMA_SEP));
1691
1692         if (commas_in_row>1)
1693             error("Two commas ',' in a row in object/class definition");
1694
1695         if ((token_type == EOF_TT)
1696             || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
1697         {   if (commas_in_row > 0)
1698                 error("Object/class definition finishes with ','");
1699             if (token_type == EOF_TT)
1700                 error("Object/class definition incomplete (no ';') at end of file");
1701             break;
1702         }
1703
1704         if (token_type != SEGMENT_MARKER_TT)
1705         {   error_named("Expected 'with', 'has' or 'class' in \
1706 object/class definition but found", token_text);
1707             break;
1708         }
1709         else
1710         switch(token_value)
1711         {   case WITH_SEGMENT:
1712                 properties_segment(WITH_SEGMENT);
1713                 break;
1714             case PRIVATE_SEGMENT:
1715                 properties_segment(PRIVATE_SEGMENT);
1716                 break;
1717             case HAS_SEGMENT:
1718                 attributes_segment();
1719                 break;
1720             case CLASS_SEGMENT:
1721                 classes_segment();
1722                 break;
1723         }
1724
1725     } while (TRUE);
1726
1727 }
1728
1729 /* ------------------------------------------------------------------------- */
1730 /*   Class directives:                                                       */
1731 /*                                                                           */
1732 /*        Class <name>  <body of definition>                                 */
1733 /* ------------------------------------------------------------------------- */
1734
1735 static void initialise_full_object(void)
1736 {
1737   int i;
1738   if (!glulx_mode) {
1739     full_object.l = 0;
1740     full_object.atts[0] = 0;
1741     full_object.atts[1] = 0;
1742     full_object.atts[2] = 0;
1743     full_object.atts[3] = 0;
1744     full_object.atts[4] = 0;
1745     full_object.atts[5] = 0;
1746   }
1747   else {
1748     full_object_g.numprops = 0;
1749     full_object_g.propdatasize = 0;
1750     for (i=0; i<NUM_ATTR_BYTES; i++)
1751       full_object_g.atts[i] = 0;
1752   }
1753 }
1754
1755 extern void make_class(char * metaclass_name)
1756 {   int n, duplicates_to_make = 0, class_number = no_objects+1,
1757         metaclass_flag = (metaclass_name != NULL);
1758     char duplicate_name[128];
1759     debug_location_beginning beginning_debug_location =
1760         get_token_location_beginning();
1761
1762     current_defn_is_class = TRUE; no_classes_to_inherit_from = 0;
1763     individual_prop_table_size = 0;
1764
1765     if (no_classes==MAX_CLASSES)
1766         memoryerror("MAX_CLASSES", MAX_CLASSES);
1767
1768     if (no_classes==VENEER_CONSTRAINT_ON_CLASSES)
1769         fatalerror("Inform's maximum possible number of classes (whatever \
1770 amount of memory is allocated) has been reached. If this causes serious \
1771 inconvenience, please contact the maintainers.");
1772
1773     directives.enabled = FALSE;
1774
1775     if (metaclass_flag)
1776     {   token_text = metaclass_name;
1777         token_value = symbol_index(token_text, -1);
1778         token_type = SYMBOL_TT;
1779     }
1780     else
1781     {   get_next_token();
1782         if (token_type != SYMBOL_TT)
1783         {   discard_token_location(beginning_debug_location);
1784             ebf_error("new class name", token_text);
1785             panic_mode_error_recovery();
1786             return;
1787         }
1788         if (!(sflags[token_value] & UNKNOWN_SFLAG))
1789         {   discard_token_location(beginning_debug_location);
1790             ebf_symbol_error("new class name", token_text, typename(stypes[token_value]), slines[token_value]);
1791             panic_mode_error_recovery();
1792             return;
1793         }
1794     }
1795
1796     /*  Each class also creates a modest object representing itself:         */
1797
1798     strcpy(shortname_buffer, token_text);
1799
1800     assign_symbol(token_value, class_number, CLASS_T);
1801     classname_text = (char *) symbs[token_value];
1802
1803     if (!glulx_mode) {
1804         if (metaclass_flag) sflags[token_value] |= SYSTEM_SFLAG;
1805     }
1806     else {
1807         /*  In Glulx, metaclasses have to be backpatched too! So we can't
1808             mark it as "system", but we should mark it "used". */
1809         if (metaclass_flag) sflags[token_value] |= USED_SFLAG;
1810     }
1811
1812     /*  "Class" (object 1) has no parent, whereas all other classes are
1813         the children of "Class".  Since "Class" is not present in a module,
1814         a special value is used which is corrected to 1 by the linker.       */
1815
1816     if (metaclass_flag) parent_of_this_obj = 0;
1817     else parent_of_this_obj = (module_switch)?MAXINTWORD:1;
1818
1819     class_object_numbers[no_classes] = class_number;
1820
1821     initialise_full_object();
1822
1823     /*  Give the class the (nameless in Inform syntax) "inheritance" property
1824         with value its own class number.  (This therefore accumulates onto
1825         the inheritance property of any object inheriting from the class,
1826         since property 2 is always set to "additive" -- see below)           */
1827
1828     if (!glulx_mode) {
1829       full_object.l = 1;
1830       full_object.pp[0].num = 2;
1831       full_object.pp[0].l = 1;
1832       full_object.pp[0].ao[0].value  = no_objects + 1;
1833       full_object.pp[0].ao[0].type   = LONG_CONSTANT_OT;
1834       full_object.pp[0].ao[0].marker = OBJECT_MV;
1835     }
1836     else {
1837       full_object_g.numprops = 1;
1838       full_object_g.props[0].num = 2;
1839       full_object_g.props[0].flags = 0;
1840       full_object_g.props[0].datastart = 0;
1841       full_object_g.props[0].continuation = 0;
1842       full_object_g.props[0].datalen = 1;
1843       full_object_g.propdatasize = 1;
1844       full_object_g.propdata[0].value  = no_objects + 1;
1845       full_object_g.propdata[0].type   = CONSTANT_OT;
1846       full_object_g.propdata[0].marker = OBJECT_MV;
1847     }
1848
1849     if (!metaclass_flag)
1850     {   get_next_token();
1851         if ((token_type == SEP_TT) && (token_value == OPENB_SEP))
1852         {   assembly_operand AO;
1853             AO = parse_expression(CONSTANT_CONTEXT);
1854             if (AO.marker != 0)
1855             {   error("Duplicate-number not known at compile time");
1856                 n=0;
1857             }
1858             else
1859                 n = AO.value;
1860             if ((n<0) || (n>10000))
1861             {   error("The number of duplicates must be 0 to 10000");
1862                 n=0;
1863             }
1864
1865             /*  Make one extra duplicate, since the veneer routines need
1866                 always to keep an undamaged prototype for the class in stock */
1867
1868             duplicates_to_make = n + 1;
1869
1870             match_close_bracket();
1871         } else put_token_back();
1872
1873         /*  Parse the body of the definition:                                */
1874
1875         parse_body_of_definition();
1876     }
1877
1878     if (debugfile_switch)
1879     {   debug_file_printf("<class>");
1880         debug_file_printf("<identifier>%s</identifier>", shortname_buffer);
1881         debug_file_printf("<class-number>%d</class-number>", no_classes);
1882         debug_file_printf("<value>");
1883         write_debug_object_backpatch(no_objects + 1);
1884         debug_file_printf("</value>");
1885         write_debug_locations
1886             (get_token_location_end(beginning_debug_location));
1887         debug_file_printf("</class>");
1888     }
1889
1890     if (!glulx_mode)
1891       manufacture_object_z();
1892     else
1893       manufacture_object_g();
1894
1895     if (individual_prop_table_size >= VENEER_CONSTRAINT_ON_IP_TABLE_SIZE)
1896         error("This class is too complex: it now carries too many properties. \
1897 You may be able to get round this by declaring some of its property names as \
1898 \"common properties\" using the 'Property' directive.");
1899
1900     if (duplicates_to_make > 0)
1901     {   sprintf(duplicate_name, "%s_1", shortname_buffer);
1902         for (n=1; (duplicates_to_make--) > 0; n++)
1903         {   if (n>1)
1904             {   int i = strlen(duplicate_name);
1905                 while (duplicate_name[i] != '_') i--;
1906                 sprintf(duplicate_name+i+1, "%d", n);
1907             }
1908             make_object(FALSE, duplicate_name, class_number, class_number, -1);
1909         }
1910     }
1911 }
1912
1913 /* ------------------------------------------------------------------------- */
1914 /*   Object/Nearby directives:                                               */
1915 /*                                                                           */
1916 /*       Object  <name-1> ... <name-n> "short name"  [parent]  <body of def> */
1917 /*                                                                           */
1918 /*       Nearby  <name-1> ... <name-n> "short name"  <body of definition>    */
1919 /* ------------------------------------------------------------------------- */
1920
1921 static int end_of_header(void)
1922 {   if (((token_type == SEP_TT) && (token_value == SEMICOLON_SEP))
1923         || ((token_type == SEP_TT) && (token_value == COMMA_SEP))
1924         || (token_type == SEGMENT_MARKER_TT)) return TRUE;
1925     return FALSE;
1926 }
1927
1928 extern void make_object(int nearby_flag,
1929     char *textual_name, int specified_parent, int specified_class,
1930     int instance_of)
1931 {
1932     /*  Ordinarily this is called with nearby_flag TRUE for "Nearby",
1933         FALSE for "Object"; and textual_name NULL, specified_parent and
1934         specified_class both -1.  The next three arguments are used when
1935         the routine is called for class duplicates manufacture (see above).
1936         The last is used to create instances of a particular class.  */
1937
1938     int i, tree_depth, internal_name_symbol = 0;
1939     char internal_name[64];
1940     debug_location_beginning beginning_debug_location =
1941         get_token_location_beginning();
1942
1943     directives.enabled = FALSE;
1944
1945     if (no_objects==MAX_OBJECTS) memoryerror("MAX_OBJECTS", MAX_OBJECTS);
1946
1947     sprintf(internal_name, "nameless_obj__%d", no_objects+1);
1948     objectname_text = internal_name;
1949
1950     current_defn_is_class = FALSE;
1951
1952     no_classes_to_inherit_from=0;
1953
1954     individual_prop_table_size = 0;
1955
1956     if (nearby_flag) tree_depth=1; else tree_depth=0;
1957
1958     if (specified_class != -1) goto HeaderPassed;
1959
1960     get_next_token();
1961
1962     /*  Read past and count a sequence of "->"s, if any are present          */
1963
1964     if ((token_type == SEP_TT) && (token_value == ARROW_SEP))
1965     {   if (nearby_flag)
1966           error("The syntax '->' is only used as an alternative to 'Nearby'");
1967
1968         while ((token_type == SEP_TT) && (token_value == ARROW_SEP))
1969         {   tree_depth++;
1970             get_next_token();
1971         }
1972     }
1973
1974     sprintf(shortname_buffer, "?");
1975
1976     segment_markers.enabled = TRUE;
1977
1978     /*  This first word is either an internal name, or a textual short name,
1979         or the end of the header part                                        */
1980
1981     if (end_of_header()) goto HeaderPassed;
1982
1983     if (token_type == DQ_TT) textual_name = token_text;
1984     else
1985     {   if (token_type != SYMBOL_TT) {
1986             ebf_error("name for new object or its textual short name",
1987                 token_text);
1988         }
1989         else if (!(sflags[token_value] & UNKNOWN_SFLAG)) {
1990             ebf_symbol_error("new object", token_text, typename(stypes[token_value]), slines[token_value]);
1991         }
1992         else
1993         {   internal_name_symbol = token_value;
1994             strcpy(internal_name, token_text);
1995         }
1996     }
1997
1998     /*  The next word is either a parent object, or
1999         a textual short name, or the end of the header part                  */
2000
2001     get_next_token_with_directives();
2002     if (end_of_header()) goto HeaderPassed;
2003
2004     if (token_type == DQ_TT)
2005     {   if (textual_name != NULL)
2006             error("Two textual short names given for only one object");
2007         else
2008             textual_name = token_text;
2009     }
2010     else
2011     {   if ((token_type != SYMBOL_TT)
2012             || (sflags[token_value] & UNKNOWN_SFLAG))
2013         {   if (textual_name == NULL)
2014                 ebf_error("parent object or the object's textual short name",
2015                     token_text);
2016             else
2017                 ebf_error("parent object", token_text);
2018         }
2019         else goto SpecParent;
2020     }
2021
2022     /*  Finally, it's possible that there is still a parent object           */
2023
2024     get_next_token();
2025     if (end_of_header()) goto HeaderPassed;
2026
2027     if (specified_parent != -1)
2028         ebf_error("body of object definition", token_text);
2029     else
2030     {   SpecParent:
2031         if ((stypes[token_value] == OBJECT_T)
2032             || (stypes[token_value] == CLASS_T))
2033         {   specified_parent = svals[token_value];
2034             sflags[token_value] |= USED_SFLAG;
2035         }
2036         else ebf_error("name of (the parent) object", token_text);
2037     }
2038
2039     /*  Now it really has to be the body of the definition.                  */
2040
2041     get_next_token_with_directives();
2042     if (end_of_header()) goto HeaderPassed;
2043
2044     ebf_error("body of object definition", token_text);
2045
2046     HeaderPassed:
2047     if (specified_class == -1) put_token_back();
2048
2049     if (internal_name_symbol > 0)
2050         assign_symbol(internal_name_symbol, no_objects + 1, OBJECT_T);
2051
2052     if (listobjects_switch)
2053         printf("%3d \"%s\"\n", no_objects+1,
2054             (textual_name==NULL)?"(with no short name)":textual_name);
2055     if (textual_name == NULL)
2056     {   if (internal_name_symbol > 0)
2057             sprintf(shortname_buffer, "(%s)",
2058                 (char *) symbs[internal_name_symbol]);
2059         else
2060             sprintf(shortname_buffer, "(%d)", no_objects+1);
2061     }
2062     else
2063     {   if (strlen(textual_name)>765)
2064             error("Short name of object (in quotes) exceeded 765 characters");
2065         strncpy(shortname_buffer, textual_name, 765);
2066     }
2067
2068     if (specified_parent != -1)
2069     {   if (tree_depth > 0)
2070             error("Use of '->' (or 'Nearby') clashes with giving a parent");
2071         parent_of_this_obj = specified_parent;
2072     }
2073     else
2074     {   parent_of_this_obj = 0;
2075         if (tree_depth>0)
2076         {
2077             /*  We have to set the parent object to the most recently defined
2078                 object at level (tree_depth - 1) in the tree.
2079
2080                 A complication is that objects are numbered 1, 2, ... in the
2081                 Z-machine (and in the objects[].parent, etc., fields) but
2082                 0, 1, 2, ... internally (and as indices to object[]).        */
2083
2084             for (i=no_objects-1; i>=0; i--)
2085             {   int j = i, k = 0;
2086
2087                 /*  Metaclass or class objects cannot be '->' parents:  */
2088                 if ((!module_switch) && (i<4))
2089                     continue;
2090
2091                 if (!glulx_mode) {
2092                     if (objectsz[i].parent == 1)
2093                         continue;
2094                     while (objectsz[j].parent != 0)
2095                     {   j = objectsz[j].parent - 1; k++; }
2096                 }
2097                 else {
2098                     if (objectsg[i].parent == 1)
2099                         continue;
2100                     while (objectsg[j].parent != 0)
2101                     {   j = objectsg[j].parent - 1; k++; }
2102                 }
2103
2104                 if (k == tree_depth - 1)
2105                 {   parent_of_this_obj = i+1;
2106                     break;
2107                 }
2108             }
2109             if (parent_of_this_obj == 0)
2110             {   if (tree_depth == 1)
2111     error("'->' (or 'Nearby') fails because there is no previous object");
2112                 else
2113     error("'-> -> ...' fails because no previous object is deep enough");
2114             }
2115         }
2116     }
2117
2118     initialise_full_object();
2119     if (instance_of != -1) add_class_to_inheritance_list(instance_of);
2120
2121     if (specified_class == -1) parse_body_of_definition();
2122     else add_class_to_inheritance_list(specified_class);
2123
2124     if (debugfile_switch)
2125     {   debug_file_printf("<object>");
2126         if (internal_name_symbol > 0)
2127         {   debug_file_printf("<identifier>%s</identifier>", internal_name);
2128         } else
2129         {   debug_file_printf
2130                 ("<identifier artificial=\"true\">%s</identifier>",
2131                  internal_name);
2132         }
2133         debug_file_printf("<value>");
2134         write_debug_object_backpatch(no_objects + 1);
2135         debug_file_printf("</value>");
2136         write_debug_locations
2137             (get_token_location_end(beginning_debug_location));
2138         debug_file_printf("</object>");
2139     }
2140
2141     if (!glulx_mode)
2142       manufacture_object_z();
2143     else
2144       manufacture_object_g();
2145 }
2146
2147 /* ========================================================================= */
2148 /*   Data structure management routines                                      */
2149 /* ------------------------------------------------------------------------- */
2150
2151 extern void init_objects_vars(void)
2152 {
2153     properties_table = NULL;
2154     prop_is_long = NULL;
2155     prop_is_additive = NULL;
2156     prop_default_value = NULL;
2157
2158     objectsz = NULL;
2159     objectsg = NULL;
2160     objectatts = NULL;
2161     classes_to_inherit_from = NULL;
2162     class_begins_at = NULL;
2163 }
2164
2165 extern void objects_begin_pass(void)
2166 {
2167     properties_table_size=0;
2168     prop_is_long[1] = TRUE; prop_is_additive[1] = TRUE;            /* "name" */
2169     prop_is_long[2] = TRUE; prop_is_additive[2] = TRUE;  /* inheritance prop */
2170     if (!glulx_mode)
2171         prop_is_long[3] = TRUE; prop_is_additive[3] = FALSE;
2172                                          /* instance variables table address */
2173     no_properties = 4;
2174
2175     if (debugfile_switch)
2176     {   debug_file_printf("<property>");
2177         debug_file_printf
2178             ("<identifier artificial=\"true\">inheritance class</identifier>");
2179         debug_file_printf("<value>2</value>");
2180         debug_file_printf("</property>");
2181         debug_file_printf("<property>");
2182         debug_file_printf
2183             ("<identifier artificial=\"true\">instance variables table address "
2184              "(Z-code)</identifier>");
2185         debug_file_printf("<value>3</value>");
2186         debug_file_printf("</property>");
2187     }
2188
2189     if (define_INFIX_switch) no_attributes = 1;
2190     else no_attributes = 0;
2191
2192     no_objects = 0;
2193     if (!glulx_mode) {
2194         objectsz[0].parent = 0; objectsz[0].child = 0; objectsz[0].next = 0;
2195         no_individual_properties=72;
2196     }
2197     else {
2198         objectsg[0].parent = 0; objectsg[0].child = 0; objectsg[0].next = 0;
2199         no_individual_properties = INDIV_PROP_START+8;
2200     }
2201     no_classes = 0;
2202
2203     no_embedded_routines = 0;
2204
2205     individuals_length=0;
2206 }
2207
2208 extern void objects_allocate_arrays(void)
2209 {
2210     objectsz = NULL;
2211     objectsg = NULL;
2212     objectatts = NULL;
2213
2214     prop_default_value    = my_calloc(sizeof(int32), INDIV_PROP_START,
2215                                 "property default values");
2216     prop_is_long          = my_calloc(sizeof(int), INDIV_PROP_START,
2217                                 "property-is-long flags");
2218     prop_is_additive      = my_calloc(sizeof(int), INDIV_PROP_START,
2219                                 "property-is-additive flags");
2220
2221     classes_to_inherit_from = my_calloc(sizeof(int), MAX_CLASSES,
2222                                 "inherited classes list");
2223     class_begins_at       = my_calloc(sizeof(int32), MAX_CLASSES,
2224                                 "pointers to classes");
2225     class_object_numbers  = my_calloc(sizeof(int),     MAX_CLASSES,
2226                                 "class object numbers");
2227
2228     properties_table      = my_malloc(MAX_PROP_TABLE_SIZE,"properties table");
2229     individuals_table     = my_malloc(MAX_INDIV_PROP_TABLE_SIZE,
2230                                 "individual properties table");
2231
2232     defined_this_segment_size = 128;
2233     defined_this_segment  = my_calloc(sizeof(int), defined_this_segment_size,
2234                                 "defined this segment table");
2235
2236     if (!glulx_mode) {
2237       objectsz            = my_calloc(sizeof(objecttz), MAX_OBJECTS,
2238                                 "z-objects");
2239     }
2240     else {
2241       objectsg            = my_calloc(sizeof(objecttg), MAX_OBJECTS,
2242                                 "g-objects");
2243       objectatts          = my_calloc(NUM_ATTR_BYTES, MAX_OBJECTS,
2244                                 "g-attributes");
2245       full_object_g.props = my_calloc(sizeof(propg), MAX_OBJ_PROP_COUNT,
2246                               "object property list");
2247       full_object_g.propdata = my_calloc(sizeof(assembly_operand),
2248                                  MAX_OBJ_PROP_TABLE_SIZE,
2249                                  "object property data table");
2250     }
2251 }
2252
2253 extern void objects_free_arrays(void)
2254 {
2255     my_free(&prop_default_value, "property default values");
2256     my_free(&prop_is_long,     "property-is-long flags");
2257     my_free(&prop_is_additive, "property-is-additive flags");
2258
2259     my_free(&objectsz,         "z-objects");
2260     my_free(&objectsg,         "g-objects");
2261     my_free(&objectatts,       "g-attributes");
2262     my_free(&class_object_numbers,"class object numbers");
2263     my_free(&classes_to_inherit_from, "inherited classes list");
2264     my_free(&class_begins_at,  "pointers to classes");
2265
2266     my_free(&properties_table, "properties table");
2267     my_free(&individuals_table,"individual properties table");
2268
2269     my_free(&defined_this_segment,"defined this segment table");
2270
2271     if (!glulx_mode) {
2272         my_free(&full_object_g.props, "object property list");
2273         my_free(&full_object_g.propdata, "object property data table");
2274     }
2275
2276 }
2277
2278 /* ========================================================================= */