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