X-Git-Url: https://jxself.org/git/?p=inform.git;a=blobdiff_plain;f=objects.c;fp=objects.c;h=0000000000000000000000000000000000000000;hp=88b1b6ab03f6fbdc49db305b9417e2eccf823da5;hb=81ffe9a7de1db0b3a318a053b38882d1b7ab304c;hpb=d1090135a32de7b38b48c55d4e21f95da4c405bc
diff --git a/objects.c b/objects.c
deleted file mode 100644
index 88b1b6a..0000000
--- a/objects.c
+++ /dev/null
@@ -1,2269 +0,0 @@
-/* ------------------------------------------------------------------------- */
-/* "objects" : [1] the object-maker, which constructs objects and enters */
-/* them into the tree, given a low-level specification; */
-/* */
-/* [2] the parser of Object/Nearby/Class directives, which */
-/* checks syntax and translates such directives into */
-/* specifications for the object-maker. */
-/* */
-/* Copyright (c) Graham Nelson 1993 - 2018 */
-/* */
-/* This file is part of Inform. */
-/* */
-/* Inform is free software: you can redistribute it and/or modify */
-/* it under the terms of the GNU General Public License as published by */
-/* the Free Software Foundation, either version 3 of the License, or */
-/* (at your option) any later version. */
-/* */
-/* Inform is distributed in the hope that it will be useful, */
-/* but WITHOUT ANY WARRANTY; without even the implied warranty of */
-/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
-/* GNU General Public License for more details. */
-/* */
-/* You should have received a copy of the GNU General Public License */
-/* along with Inform. If not, see https://gnu.org/licenses/ */
-/* */
-/* ------------------------------------------------------------------------- */
-
-#include "header.h"
-
-/* ------------------------------------------------------------------------- */
-/* Objects. */
-/* ------------------------------------------------------------------------- */
-
-int no_objects; /* Number of objects made so far */
-
-static int no_embedded_routines; /* Used for naming routines which
- are given as property values: these
- are called EmbeddedRoutine__1, ... */
-
-static fpropt full_object; /* "fpropt" is a typedef for a struct
- containing an array to hold the
- attribute and property values of
- a single object. We only keep one
- of these, for the current object
- being made, and compile it into
- Z-machine tables when each object
- definition is complete, since
- sizeof(fpropt) is about 6200 bytes */
-static fproptg full_object_g; /* Equivalent for Glulx. This object
- is very small, since the large arrays
- are allocated dynamically by the
- Glulx compiler */
-static char shortname_buffer[766]; /* Text buffer to hold the short name
- (which is read in first, but
- written almost last) */
-static int parent_of_this_obj;
-
-static char *classname_text, *objectname_text;
- /* For printing names of embedded
- routines only */
-
-/* ------------------------------------------------------------------------- */
-/* Classes. */
-/* ------------------------------------------------------------------------- */
-/* Arrays defined below: */
-/* */
-/* int32 class_begins_at[n] offset of properties block for */
-/* nth class (always an offset */
-/* inside the properties_table) */
-/* int classes_to_inherit_from[] The list of classes to inherit */
-/* from as taken from the current */
-/* Nearby/Object/Class definition */
-/* int class_object_numbers[n] The number of the prototype-object */
-/* for the nth class */
-/* ------------------------------------------------------------------------- */
-
-int no_classes; /* Number of class defns made so far */
-
-static int current_defn_is_class, /* TRUE if current Nearby/Object/Class
- defn is in fact a Class definition */
- no_classes_to_inherit_from; /* Number of classes in the list
- of classes to inherit in the
- current Nearby/Object/Class defn */
-
-/* ------------------------------------------------------------------------- */
-/* Making attributes and properties. */
-/* ------------------------------------------------------------------------- */
-
-int no_attributes, /* Number of attributes defined so far */
- no_properties; /* Number of properties defined so far,
- plus 1 (properties are numbered from
- 1 and Inform creates "name" and two
- others itself, so the variable begins
- the compilation pass set to 4) */
-
-static void trace_s(char *name, int32 number, int f)
-{ if (!printprops_switch) return;
- printf("%s %02ld ",(f==0)?"Attr":"Prop",(long int) number);
- if (f==0) printf(" ");
- else printf("%s%s",(prop_is_long[number])?"L":" ",
- (prop_is_additive[number])?"A":" ");
- printf(" %s\n",name);
-}
-
-extern void make_attribute(void)
-{ int i; char *name;
- debug_location_beginning beginning_debug_location =
- get_token_location_beginning();
-
- if (!glulx_mode) {
- if (no_attributes==((version_number==3)?32:48))
- { discard_token_location(beginning_debug_location);
- if (version_number==3)
- error("All 32 attributes already declared (compile as Advanced \
-game to get an extra 16)");
- else
- error("All 48 attributes already declared");
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
- }
- else {
- if (no_attributes==NUM_ATTR_BYTES*8) {
- discard_token_location(beginning_debug_location);
- error_numbered(
- "All attributes already declared -- increase NUM_ATTR_BYTES to use \
-more than",
- NUM_ATTR_BYTES*8);
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
- }
-
- get_next_token();
- i = token_value; name = token_text;
- if ((token_type != SYMBOL_TT) || (!(sflags[i] & UNKNOWN_SFLAG)))
- { discard_token_location(beginning_debug_location);
- ebf_error("new attribute name", token_text);
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
-
- directive_keywords.enabled = TRUE;
- get_next_token();
- directive_keywords.enabled = FALSE;
-
- if ((token_type == DIR_KEYWORD_TT) && (token_value == ALIAS_DK))
- { get_next_token();
- if (!((token_type == SYMBOL_TT)
- && (stypes[token_value] == ATTRIBUTE_T)))
- { discard_token_location(beginning_debug_location);
- ebf_error("an existing attribute name after 'alias'",
- token_text);
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
- assign_symbol(i, svals[token_value], ATTRIBUTE_T);
- sflags[token_value] |= ALIASED_SFLAG;
- sflags[i] |= ALIASED_SFLAG;
- }
- else
- { assign_symbol(i, no_attributes++, ATTRIBUTE_T);
- put_token_back();
- }
-
- if (debugfile_switch)
- { debug_file_printf("");
- debug_file_printf("%s", name);
- debug_file_printf("%d", svals[i]);
- write_debug_locations(get_token_location_end(beginning_debug_location));
- debug_file_printf("");
- }
-
- trace_s(name, svals[i], 0);
- return;
-}
-
-extern void make_property(void)
-{ int32 default_value, i;
- int additive_flag=FALSE; char *name;
- assembly_operand AO;
- debug_location_beginning beginning_debug_location =
- get_token_location_beginning();
-
- if (!glulx_mode) {
- if (no_properties==((version_number==3)?32:64))
- { discard_token_location(beginning_debug_location);
- if (version_number==3)
- error("All 30 properties already declared (compile as \
-Advanced game to get an extra 62)");
- else
- error("All 62 properties already declared");
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
- }
- else {
- if (no_properties==INDIV_PROP_START) {
- discard_token_location(beginning_debug_location);
- error_numbered("All properties already declared -- max is",
- INDIV_PROP_START);
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
- }
-
- do
- { directive_keywords.enabled = TRUE;
- get_next_token();
- if ((token_type == DIR_KEYWORD_TT) && (token_value == LONG_DK))
- obsolete_warning("all properties are now automatically 'long'");
- else
- if ((token_type == DIR_KEYWORD_TT) && (token_value == ADDITIVE_DK))
- additive_flag = TRUE;
- else break;
- } while (TRUE);
-
- put_token_back();
- directive_keywords.enabled = FALSE;
- get_next_token();
-
- i = token_value; name = token_text;
- if ((token_type != SYMBOL_TT) || (!(sflags[i] & UNKNOWN_SFLAG)))
- { discard_token_location(beginning_debug_location);
- ebf_error("new property name", token_text);
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
-
- directive_keywords.enabled = TRUE;
- get_next_token();
- directive_keywords.enabled = FALSE;
-
- if (strcmp(name+strlen(name)-3, "_to") == 0) sflags[i] |= STAR_SFLAG;
-
- if ((token_type == DIR_KEYWORD_TT) && (token_value == ALIAS_DK))
- { discard_token_location(beginning_debug_location);
- if (additive_flag)
- { error("'alias' incompatible with 'additive'");
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
- get_next_token();
- if (!((token_type == SYMBOL_TT)
- && (stypes[token_value] == PROPERTY_T)))
- { ebf_error("an existing property name after 'alias'",
- token_text);
- panic_mode_error_recovery();
- put_token_back();
- return;
- }
-
- assign_symbol(i, svals[token_value], PROPERTY_T);
- trace_s(name, svals[i], 1);
- sflags[token_value] |= ALIASED_SFLAG;
- sflags[i] |= ALIASED_SFLAG;
- return;
- }
-
- default_value = 0;
- put_token_back();
-
- if (!((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { AO = parse_expression(CONSTANT_CONTEXT);
- default_value = AO.value;
- if (AO.marker != 0)
- backpatch_zmachine(AO.marker, PROP_DEFAULTS_ZA,
- (no_properties-1) * WORDSIZE);
- }
-
- prop_default_value[no_properties] = default_value;
- prop_is_long[no_properties] = TRUE;
- prop_is_additive[no_properties] = additive_flag;
-
- assign_symbol(i, no_properties++, PROPERTY_T);
-
- if (debugfile_switch)
- { debug_file_printf("");
- debug_file_printf("%s", name);
- debug_file_printf("%d", svals[i]);
- write_debug_locations
- (get_token_location_end(beginning_debug_location));
- debug_file_printf("");
- }
-
- trace_s(name, svals[i], 1);
-}
-
-/* ------------------------------------------------------------------------- */
-/* Properties. */
-/* ------------------------------------------------------------------------- */
-
-int32 *prop_default_value; /* Default values for properties */
-int *prop_is_long, /* Property modifiers, TRUE or FALSE:
- "long" means "never write a 1-byte
- value to this property", and is an
- obsolete feature: since Inform 5
- all properties have been "long" */
- *prop_is_additive; /* "additive" means that values
- accumulate rather than erase each
- other during class inheritance */
-char *properties_table; /* Holds the table of property values
- (holding one block for each object
- and coming immediately after the
- object tree in Z-memory) */
-int properties_table_size; /* Number of bytes in this table */
-
-/* ------------------------------------------------------------------------- */
-/* Individual properties */
-/* */
-/* Each new i.p. name is given a unique number. These numbers start from */
-/* 72, since 0 is reserved as a null, 1 to 63 refer to common properties */
-/* and 64 to 71 are kept for methods of the metaclass Class (for example, */
-/* 64 is "create"). */
-/* */
-/* An object provides individual properties by having property 3 set to a */
-/* non-zero value, which must be a byte address of a table in the form: */
-/* */
-/* ... 00 00 */
-/* */
-/* where a looks like */
-/* */
-/* */
-/* or */
-/* ----- 2 bytes ---------- 1 byte number of bytes */
-/* */
-/* The part is the number allocated to the name of what is */
-/* being provided. The top bit of this word is set to indicate that */
-/* although the individual property is being provided, it is provided */
-/* only privately (so that it is inaccessible except to the object's own */
-/* embedded routines). */
-/* */
-/* In Glulx: i-props are numbered from INDIV_PROP_START+8 up. And all */
-/* properties, common and individual, are stored in the same table. */
-/* ------------------------------------------------------------------------- */
-
- int no_individual_properties; /* Actually equal to the next
- identifier number to be allocated,
- so this is initially 72 even though
- none have been made yet. */
-static int individual_prop_table_size; /* Size of the table of individual
- properties so far for current obj */
- uchar *individuals_table; /* Table of records, each being the
- i.p. table for an object */
- int i_m; /* Write mark position in the above */
- int individuals_length; /* Extent of individuals_table */
-
-/* ------------------------------------------------------------------------- */
-/* Arrays used by this file */
-/* ------------------------------------------------------------------------- */
-
-objecttz *objectsz; /* Z-code only */
-objecttg *objectsg; /* Glulx only */
-uchar *objectatts; /* Glulx only */
-static int *classes_to_inherit_from;
-int *class_object_numbers;
-int32 *class_begins_at;
-
-
-/* ------------------------------------------------------------------------- */
-/* Tracing for compiler maintenance */
-/* ------------------------------------------------------------------------- */
-
-extern void list_object_tree(void)
-{ int i;
- printf("obj par nxt chl Object tree:\n");
- for (i=0; i 2)
- prop_length = class_prop_block[j++]%64;
- }
-
- /* So we now have property number prop_number present in the
- property block for the class being read: its bytes are
-
- class_prop_block[j, ..., j + prop_length - 1]
-
- Question now is: is there already a value given in the
- current definition under this property name? */
-
- prop_in_current_defn = FALSE;
-
- kmax = full_object.l;
-
- for (k=0; k= 32)
- { error("An additive property has inherited \
-so many values that the list has overflowed the maximum 32 entries");
- break;
- }
- full_object.pp[k].ao[i].value = mark + j;
- j += 2;
- full_object.pp[k].ao[i].marker = INHERIT_MV;
- full_object.pp[k].ao[i].type = LONG_CONSTANT_OT;
- }
- full_object.pp[k].l += prop_length/2;
- }
- else
- /* The ordinary case: the full_object property
- values simply overrides the class definition,
- so we skip over the values in the class table */
-
- j+=prop_length;
-
- if (prop_number==3)
- { int y, z, class_block_offset;
- uchar *p;
-
- /* Property 3 holds the address of the table of
- instance variables, so this is the case where
- the object already has instance variables in its
- own table but must inherit some more from the
- class */
-
- class_block_offset = class_prop_block[j-2]*256
- + class_prop_block[j-1];
-
- p = individuals_table + class_block_offset;
- z = class_block_offset;
- while ((p[0]!=0)||(p[1]!=0))
- { int already_present = FALSE, l;
- for (l = full_object.pp[k].ao[0].value; l < i_m;
- l = l + 3 + individuals_table[l + 2])
- if (individuals_table[l] == p[0]
- && individuals_table[l + 1] == p[1])
- { already_present = TRUE; break;
- }
- if (already_present == FALSE)
- { if (module_switch)
- backpatch_zmachine(IDENT_MV,
- INDIVIDUAL_PROP_ZA, i_m);
- if (i_m+3+p[2] > MAX_INDIV_PROP_TABLE_SIZE)
- memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
- MAX_INDIV_PROP_TABLE_SIZE);
- individuals_table[i_m++] = p[0];
- individuals_table[i_m++] = p[1];
- individuals_table[i_m++] = p[2];
- for (y=0;y < p[2]/2;y++)
- { individuals_table[i_m++] = (z+3+y*2)/256;
- individuals_table[i_m++] = (z+3+y*2)%256;
- backpatch_zmachine(INHERIT_INDIV_MV,
- INDIVIDUAL_PROP_ZA, i_m-2);
- }
- }
- z += p[2] + 3;
- p += p[2] + 3;
- }
- individuals_length = i_m;
- }
-
- /* For efficiency we exit the loop now (this property
- number has been dealt with) */
-
- break;
- }
-
- if (!prop_in_current_defn)
- {
- /* The case where the class defined a property which wasn't
- defined at all in full_object: we copy out the data into
- a new property added to full_object */
-
- k=full_object.l++;
- full_object.pp[k].num = prop_number;
- full_object.pp[k].l = prop_length/2;
- for (i=0; i MAX_INDIV_PROP_TABLE_SIZE)
- memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
- MAX_INDIV_PROP_TABLE_SIZE);
- individuals_table[i_m++] = p[0];
- individuals_table[i_m++] = p[1];
- individuals_table[i_m++] = p[2];
- for (y=0;y < p[2]/2;y++)
- { individuals_table[i_m++] = (z+3+y*2)/256;
- individuals_table[i_m++] = (z+3+y*2)%256;
- backpatch_zmachine(INHERIT_INDIV_MV,
- INDIVIDUAL_PROP_ZA, i_m-2);
- }
- z += p[2] + 3;
- p += p[2] + 3;
- }
- individuals_length = i_m;
- }
- }
- }
- }
-
- if (individual_prop_table_size > 0)
- {
- if (i_m+2 > MAX_INDIV_PROP_TABLE_SIZE)
- memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
- MAX_INDIV_PROP_TABLE_SIZE);
-
- individuals_table[i_m++] = 0;
- individuals_table[i_m++] = 0;
- individuals_length += 2;
- }
-}
-
-static void property_inheritance_g(void)
-{
- /* Apply the property inheritance rules to full_object, which should
- initially be complete (i.e., this routine takes place after the whole
- Nearby/Object/Class definition has been parsed through).
-
- On exit, full_object contains the final state of the properties to
- be written. */
-
- int i, j, k, class, num_props,
- prop_number, prop_length, prop_flags, prop_in_current_defn;
- int32 mark, prop_addr;
- uchar *cpb, *pe;
-
- ASSERT_GLULX();
-
- for (class=0; class MAX_OBJ_PROP_TABLE_SIZE) {
- memoryerror("MAX_OBJ_PROP_TABLE_SIZE",MAX_OBJ_PROP_TABLE_SIZE);
- }
-
- for (i=0; i MAX_OBJ_PROP_TABLE_SIZE) {
- memoryerror("MAX_OBJ_PROP_TABLE_SIZE",MAX_OBJ_PROP_TABLE_SIZE);
- }
-
- for (i=0; i=from; prop_number--)
- { for (j=0; j= MAX_PROP_TABLE_SIZE)
- memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
- if (version_number == 3)
- p[mark++] = prop_number + (prop_length - 1)*32;
- else
- { switch(prop_length)
- { case 1:
- p[mark++] = prop_number; break;
- case 2:
- p[mark++] = prop_number + 0x40; break;
- default:
- p[mark++] = prop_number + 0x80;
- p[mark++] = prop_length + 0x80; break;
- }
- }
-
- for (k=0; k= MAX_PROP_TABLE_SIZE)
- memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
- tmp = translate_text(p+mark+1,p+mark+1+510,shortname);
- if (!tmp) error ("Short name of object exceeded 765 Z-characters");
- i = subtract_pointers(tmp,(p+mark+1));
- p[mark] = i/2;
- mark += i+1;
- }
- if (current_defn_is_class)
- { mark = write_properties_between(p,mark,3,3);
- for (i=0;i<6;i++)
- p[mark++] = full_object.atts[i];
- class_begins_at[no_classes++] = mark;
- }
-
- mark = write_properties_between(p, mark, 1, (version_number==3)?31:63);
-
- i = mark - properties_table_size;
- properties_table_size = mark;
-
- return(i);
-}
-
-static int gpropsort(void *ptr1, void *ptr2)
-{
- propg *prop1 = ptr1;
- propg *prop2 = ptr2;
-
- if (prop2->num == -1)
- return -1;
- if (prop1->num == -1)
- return 1;
- if (prop1->num < prop2->num)
- return -1;
- if (prop1->num > prop2->num)
- return 1;
-
- return (prop1->continuation - prop2->continuation);
-}
-
-static int32 write_property_block_g(void)
-{
- /* Compile the (now complete) full_object properties into a
- property-table block at "p" in Inform's memory.
- Return the number of bytes written to the block.
- In Glulx, the shortname property isn't used here; it's already
- been compiled into an ordinary string. */
-
- int32 i;
- int ix, jx, kx, totalprops;
- int32 mark = properties_table_size;
- int32 datamark;
- uchar *p = (uchar *) properties_table;
-
- if (current_defn_is_class) {
- for (i=0;i= MAX_PROP_TABLE_SIZE)
- memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
- WriteInt32(p+mark, totalprops);
- mark += 4;
-
- datamark = mark + 10*totalprops;
-
- for (ix=0; ix= MAX_PROP_TABLE_SIZE)
- memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
- for (kx=0; kx= MAX_PROP_TABLE_SIZE)
- memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
- WriteInt16(p+mark, propnum);
- mark += 2;
- WriteInt16(p+mark, totallen);
- mark += 2;
- WriteInt32(p+mark, datamarkstart);
- mark += 4;
- WriteInt16(p+mark, flags);
- mark += 2;
- }
-
- mark = datamark;
-
- i = mark - properties_table_size;
- properties_table_size = mark;
- return i;
-}
-
-/* ------------------------------------------------------------------------- */
-/* The final stage in Nearby/Object/Class definition processing. */
-/* ------------------------------------------------------------------------- */
-
-static void manufacture_object_z(void)
-{ int i, j;
-
- segment_markers.enabled = FALSE;
- directives.enabled = TRUE;
-
- property_inheritance_z();
-
- objectsz[no_objects].parent = parent_of_this_obj;
- objectsz[no_objects].next = 0;
- objectsz[no_objects].child = 0;
-
- if ((parent_of_this_obj > 0) && (parent_of_this_obj != 0x7fff))
- { i = objectsz[parent_of_this_obj-1].child;
- if (i == 0)
- objectsz[parent_of_this_obj-1].child = no_objects + 1;
- else
- { while(objectsz[i-1].next != 0) i = objectsz[i-1].next;
- objectsz[i-1].next = no_objects+1;
- }
- }
-
- /* The properties table consists simply of a sequence of property
- blocks, one for each object in order of definition, exactly as
- it will appear in the final Z-machine. */
-
- j = write_property_block_z(shortname_buffer);
-
- objectsz[no_objects].propsize = j;
- if (properties_table_size >= MAX_PROP_TABLE_SIZE)
- memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
-
- if (current_defn_is_class)
- for (i=0;i<6;i++) objectsz[no_objects].atts[i] = 0;
- else
- for (i=0;i<6;i++)
- objectsz[no_objects].atts[i] = full_object.atts[i];
-
- no_objects++;
-}
-
-static void manufacture_object_g(void)
-{ int32 i, j;
-
- segment_markers.enabled = FALSE;
- directives.enabled = TRUE;
-
- property_inheritance_g();
-
- objectsg[no_objects].parent = parent_of_this_obj;
- objectsg[no_objects].next = 0;
- objectsg[no_objects].child = 0;
-
- if ((parent_of_this_obj > 0) && (parent_of_this_obj != 0x7fffffff))
- { i = objectsg[parent_of_this_obj-1].child;
- if (i == 0)
- objectsg[parent_of_this_obj-1].child = no_objects + 1;
- else
- { while(objectsg[i-1].next != 0) i = objectsg[i-1].next;
- objectsg[i-1].next = no_objects+1;
- }
- }
-
- objectsg[no_objects].shortname = compile_string(shortname_buffer,
- FALSE, FALSE);
-
- /* The properties table consists simply of a sequence of property
- blocks, one for each object in order of definition, exactly as
- it will appear in the final machine image. */
-
- j = write_property_block_g();
-
- objectsg[no_objects].propaddr = full_object_g.finalpropaddr;
-
- objectsg[no_objects].propsize = j;
- if (properties_table_size >= MAX_PROP_TABLE_SIZE)
- memoryerror("MAX_PROP_TABLE_SIZE",MAX_PROP_TABLE_SIZE);
-
- if (current_defn_is_class)
- for (i=0;i , , ...,
-
- This routine also handles "private", with this_segment being equal
- to the token value for the introductory word ("private" or "with"). */
-
-
- int i, property_name_symbol, property_number=0, next_prop=0, length,
- individual_property, this_identifier_number;
-
- do
- { get_next_token_with_directives();
- if ((token_type == SEGMENT_MARKER_TT)
- || (token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { put_token_back(); return;
- }
-
- if (token_type != SYMBOL_TT)
- { ebf_error("property name", token_text);
- return;
- }
-
- individual_property = (stypes[token_value] != PROPERTY_T);
-
- if (individual_property)
- { if (sflags[token_value] & UNKNOWN_SFLAG)
- { this_identifier_number = no_individual_properties++;
- assign_symbol(token_value, this_identifier_number,
- INDIVIDUAL_PROPERTY_T);
-
- if (debugfile_switch)
- { debug_file_printf("");
- debug_file_printf
- ("%s", token_text);
- debug_file_printf
- ("%d", this_identifier_number);
- debug_file_printf("");
- }
-
- }
- else
- { if (stypes[token_value]==INDIVIDUAL_PROPERTY_T)
- this_identifier_number = svals[token_value];
- else
- { char already_error[128];
- sprintf(already_error,
- "\"%s\" is a name already in use (with type %s) \
-and may not be used as a property name too",
- token_text, typename(stypes[token_value]));
- error(already_error);
- return;
- }
- }
-
- if (def_t_s >= defined_this_segment_size)
- ensure_defined_this_segment(def_t_s*2);
- defined_this_segment[def_t_s++] = token_value;
-
- if (individual_prop_table_size++ == 0)
- { full_object.pp[full_object.l].num = 3;
- full_object.pp[full_object.l].l = 1;
- full_object.pp[full_object.l].ao[0].value
- = individuals_length;
- full_object.pp[full_object.l].ao[0].type = LONG_CONSTANT_OT;
- full_object.pp[full_object.l].ao[0].marker = INDIVPT_MV;
-
- i_m = individuals_length;
- full_object.l++;
- }
- individuals_table[i_m] = this_identifier_number/256;
- if (this_segment == PRIVATE_SEGMENT)
- individuals_table[i_m] |= 0x80;
- individuals_table[i_m+1] = this_identifier_number%256;
- if (module_switch)
- backpatch_zmachine(IDENT_MV, INDIVIDUAL_PROP_ZA, i_m);
- individuals_table[i_m+2] = 0;
- }
- else
- { if (sflags[token_value] & UNKNOWN_SFLAG)
- { error_named("No such property name as", token_text);
- return;
- }
- if (this_segment == PRIVATE_SEGMENT)
- error_named("Property should be declared in 'with', \
-not 'private':", token_text);
- if (def_t_s >= defined_this_segment_size)
- ensure_defined_this_segment(def_t_s*2);
- defined_this_segment[def_t_s++] = token_value;
- property_number = svals[token_value];
-
- next_prop=full_object.l++;
- full_object.pp[next_prop].num = property_number;
- }
-
- for (i=0; i<(def_t_s-1); i++)
- if (defined_this_segment[i] == token_value)
- { error_named("Property given twice in the same declaration:",
- (char *) symbs[token_value]);
- }
- else
- if (svals[defined_this_segment[i]] == svals[token_value])
- { char error_b[128];
- sprintf(error_b,
- "Property given twice in the same declaration, because \
-the names '%s' and '%s' actually refer to the same property",
- (char *) symbs[defined_this_segment[i]],
- (char *) symbs[token_value]);
- error(error_b);
- }
-
- property_name_symbol = token_value;
- sflags[token_value] |= USED_SFLAG;
-
- length=0;
- do
- { assembly_operand AO;
- get_next_token_with_directives();
- if ((token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP))
- || ((token_type == SEP_TT) && (token_value == COMMA_SEP)))
- break;
-
- if (token_type == SEGMENT_MARKER_TT) { put_token_back(); break; }
-
- if ((!individual_property) && (property_number==1)
- && ((token_type != SQ_TT) || (strlen(token_text) <2 ))
- && (token_type != DQ_TT)
- )
- warning ("'name' property should only contain dictionary words");
-
- if ((token_type == SEP_TT) && (token_value == OPEN_SQUARE_SEP))
- { char embedded_name[80];
- if (current_defn_is_class)
- { sprintf(embedded_name,
- "%s::%s", classname_text,
- (char *) symbs[property_name_symbol]);
- }
- else
- { sprintf(embedded_name,
- "%s.%s", objectname_text,
- (char *) symbs[property_name_symbol]);
- }
- AO.value = parse_routine(NULL, TRUE, embedded_name, FALSE, -1);
- AO.type = LONG_CONSTANT_OT;
- AO.marker = IROUTINE_MV;
-
- directives.enabled = FALSE;
- segment_markers.enabled = TRUE;
-
- statements.enabled = FALSE;
- misc_keywords.enabled = FALSE;
- local_variables.enabled = FALSE;
- system_functions.enabled = FALSE;
- conditions.enabled = FALSE;
- }
- else
-
- /* A special rule applies to values in double-quotes of the
- built-in property "name", which always has number 1: such
- property values are dictionary entries and not static
- strings */
-
- if ((!individual_property) &&
- (property_number==1) && (token_type == DQ_TT))
- { AO.value = dictionary_add(token_text, 0x80, 0, 0);
- AO.type = LONG_CONSTANT_OT;
- AO.marker = DWORD_MV;
- }
- else
- { if (length!=0)
- {
- if ((token_type == SYMBOL_TT)
- && (stypes[token_value]==PROPERTY_T))
- {
- /* This is not necessarily an error: it's possible
- to imagine a property whose value is a list
- of other properties to look up, but far more
- likely that a comma has been omitted in between
- two property blocks */
-
- warning_named(
- "Missing ','? Property data seems to contain the property name",
- token_text);
- }
- }
-
- /* An ordinary value, then: */
-
- put_token_back();
- AO = parse_expression(ARRAY_CONTEXT);
- }
-
- if (length == 64)
- { error_named("Limit (of 32 values) exceeded for property",
- (char *) symbs[property_name_symbol]);
- break;
- }
-
- if (individual_property)
- { if (AO.marker != 0)
- backpatch_zmachine(AO.marker, INDIVIDUAL_PROP_ZA,
- i_m+3+length);
- individuals_table[i_m+3+length++] = AO.value/256;
- individuals_table[i_m+3+length++] = AO.value%256;
- }
- else
- { full_object.pp[next_prop].ao[length/2] = AO;
- length = length + 2;
- }
-
- } while (TRUE);
-
- /* People rarely do, but it is legal to declare a property without
- a value at all:
-
- with name "fish", number, time_left;
-
- in which case the properties "number" and "time_left" are
- created as in effect variables and initialised to zero. */
-
- if (length == 0)
- { if (individual_property)
- { individuals_table[i_m+3+length++] = 0;
- individuals_table[i_m+3+length++] = 0;
- }
- else
- { full_object.pp[next_prop].ao[0].value = 0;
- full_object.pp[next_prop].ao[0].type = LONG_CONSTANT_OT;
- full_object.pp[next_prop].ao[0].marker = 0;
- length = 2;
- }
- }
-
- if ((version_number==3) && (!individual_property))
- { if (length > 8)
- {
- warning_named("Version 3 limit of 4 values per property exceeded \
-(use -v5 to get 32), so truncating property",
- (char *) symbs[property_name_symbol]);
- full_object.pp[next_prop].l=4;
- }
- }
-
- if (individual_property)
- {
- if (individuals_length+length+3 > MAX_INDIV_PROP_TABLE_SIZE)
- memoryerror("MAX_INDIV_PROP_TABLE_SIZE",
- MAX_INDIV_PROP_TABLE_SIZE);
- individuals_table[i_m + 2] = length;
- individuals_length += length+3;
- i_m = individuals_length;
- }
- else
- full_object.pp[next_prop].l = length/2;
-
- if ((token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { put_token_back(); return;
- }
-
- } while (TRUE);
-}
-
-
-static void properties_segment_g(int this_segment)
-{
- /* Parse through the "with" part of an object/class definition:
-
- , , ...,
-
- This routine also handles "private", with this_segment being equal
- to the token value for the introductory word ("private" or "with"). */
-
-
- int i, next_prop,
- individual_property, this_identifier_number;
- int32 property_name_symbol, property_number, length;
-
- do
- { get_next_token_with_directives();
- if ((token_type == SEGMENT_MARKER_TT)
- || (token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { put_token_back(); return;
- }
-
- if (token_type != SYMBOL_TT)
- { ebf_error("property name", token_text);
- return;
- }
-
- individual_property = (stypes[token_value] != PROPERTY_T);
-
- if (individual_property)
- { if (sflags[token_value] & UNKNOWN_SFLAG)
- { this_identifier_number = no_individual_properties++;
- assign_symbol(token_value, this_identifier_number,
- INDIVIDUAL_PROPERTY_T);
-
- if (debugfile_switch)
- { debug_file_printf("");
- debug_file_printf
- ("%s", token_text);
- debug_file_printf
- ("%d", this_identifier_number);
- debug_file_printf("");
- }
-
- }
- else
- { if (stypes[token_value]==INDIVIDUAL_PROPERTY_T)
- this_identifier_number = svals[token_value];
- else
- { char already_error[128];
- sprintf(already_error,
- "\"%s\" is a name already in use (with type %s) \
-and may not be used as a property name too",
- token_text, typename(stypes[token_value]));
- error(already_error);
- return;
- }
- }
-
- if (def_t_s >= defined_this_segment_size)
- ensure_defined_this_segment(def_t_s*2);
- defined_this_segment[def_t_s++] = token_value;
- property_number = svals[token_value];
-
- next_prop=full_object_g.numprops++;
- full_object_g.props[next_prop].num = property_number;
- full_object_g.props[next_prop].flags =
- ((this_segment == PRIVATE_SEGMENT) ? 1 : 0);
- full_object_g.props[next_prop].datastart = full_object_g.propdatasize;
- full_object_g.props[next_prop].continuation = 0;
- full_object_g.props[next_prop].datalen = 0;
- }
- else
- { if (sflags[token_value] & UNKNOWN_SFLAG)
- { error_named("No such property name as", token_text);
- return;
- }
- if (this_segment == PRIVATE_SEGMENT)
- error_named("Property should be declared in 'with', \
-not 'private':", token_text);
-
- if (def_t_s >= defined_this_segment_size)
- ensure_defined_this_segment(def_t_s*2);
- defined_this_segment[def_t_s++] = token_value;
- property_number = svals[token_value];
-
- next_prop=full_object_g.numprops++;
- full_object_g.props[next_prop].num = property_number;
- full_object_g.props[next_prop].flags = 0;
- full_object_g.props[next_prop].datastart = full_object_g.propdatasize;
- full_object_g.props[next_prop].continuation = 0;
- full_object_g.props[next_prop].datalen = 0;
- }
-
- for (i=0; i<(def_t_s-1); i++)
- if (defined_this_segment[i] == token_value)
- { error_named("Property given twice in the same declaration:",
- (char *) symbs[token_value]);
- }
- else
- if (svals[defined_this_segment[i]] == svals[token_value])
- { char error_b[128];
- sprintf(error_b,
- "Property given twice in the same declaration, because \
-the names '%s' and '%s' actually refer to the same property",
- (char *) symbs[defined_this_segment[i]],
- (char *) symbs[token_value]);
- error(error_b);
- }
-
- if (full_object_g.numprops == MAX_OBJ_PROP_COUNT) {
- memoryerror("MAX_OBJ_PROP_COUNT",MAX_OBJ_PROP_COUNT);
- }
-
- property_name_symbol = token_value;
- sflags[token_value] |= USED_SFLAG;
-
- length=0;
- do
- { assembly_operand AO;
- get_next_token_with_directives();
- if ((token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP))
- || ((token_type == SEP_TT) && (token_value == COMMA_SEP)))
- break;
-
- if (token_type == SEGMENT_MARKER_TT) { put_token_back(); break; }
-
- if ((!individual_property) && (property_number==1)
- && (token_type != SQ_TT) && (token_type != DQ_TT)
- )
- warning ("'name' property should only contain dictionary words");
-
- if ((token_type == SEP_TT) && (token_value == OPEN_SQUARE_SEP))
- { char embedded_name[80];
- if (current_defn_is_class)
- { sprintf(embedded_name,
- "%s::%s", classname_text,
- (char *) symbs[property_name_symbol]);
- }
- else
- { sprintf(embedded_name,
- "%s.%s", objectname_text,
- (char *) symbs[property_name_symbol]);
- }
- AO.value = parse_routine(NULL, TRUE, embedded_name, FALSE, -1);
- AO.type = CONSTANT_OT;
- AO.marker = IROUTINE_MV;
-
- directives.enabled = FALSE;
- segment_markers.enabled = TRUE;
-
- statements.enabled = FALSE;
- misc_keywords.enabled = FALSE;
- local_variables.enabled = FALSE;
- system_functions.enabled = FALSE;
- conditions.enabled = FALSE;
- }
- else
-
- /* A special rule applies to values in double-quotes of the
- built-in property "name", which always has number 1: such
- property values are dictionary entries and not static
- strings */
-
- if ((!individual_property) &&
- (property_number==1) && (token_type == DQ_TT))
- { AO.value = dictionary_add(token_text, 0x80, 0, 0);
- AO.type = CONSTANT_OT;
- AO.marker = DWORD_MV;
- }
- else
- { if (length!=0)
- {
- if ((token_type == SYMBOL_TT)
- && (stypes[token_value]==PROPERTY_T))
- {
- /* This is not necessarily an error: it's possible
- to imagine a property whose value is a list
- of other properties to look up, but far more
- likely that a comma has been omitted in between
- two property blocks */
-
- warning_named(
- "Missing ','? Property data seems to contain the property name",
- token_text);
- }
- }
-
- /* An ordinary value, then: */
-
- put_token_back();
- AO = parse_expression(ARRAY_CONTEXT);
- }
-
- if (length == 32768) /* VENEER_CONSTRAINT_ON_PROP_TABLE_SIZE? */
- { error_named("Limit (of 32768 values) exceeded for property",
- (char *) symbs[property_name_symbol]);
- break;
- }
-
- if (full_object_g.propdatasize >= MAX_OBJ_PROP_TABLE_SIZE) {
- memoryerror("MAX_OBJ_PROP_TABLE_SIZE",MAX_OBJ_PROP_TABLE_SIZE);
- }
-
- full_object_g.propdata[full_object_g.propdatasize++] = AO;
- length += 1;
-
- } while (TRUE);
-
- /* People rarely do, but it is legal to declare a property without
- a value at all:
-
- with name "fish", number, time_left;
-
- in which case the properties "number" and "time_left" are
- created as in effect variables and initialised to zero. */
-
- if (length == 0)
- {
- assembly_operand AO;
- AO.value = 0;
- AO.type = CONSTANT_OT;
- AO.marker = 0;
- full_object_g.propdata[full_object_g.propdatasize++] = AO;
- length += 1;
- }
-
- full_object_g.props[next_prop].datalen = length;
-
- if ((token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { put_token_back(); return;
- }
-
- } while (TRUE);
-}
-
-static void properties_segment(int this_segment)
-{
- if (!glulx_mode)
- properties_segment_z(this_segment);
- else
- properties_segment_g(this_segment);
-}
-
-/* ------------------------------------------------------------------------- */
-/* Attributes ("has") segment. */
-/* ------------------------------------------------------------------------- */
-
-static void attributes_segment(void)
-{
- /* Parse through the "has" part of an object/class definition:
-
- [~] [~] ... [~] */
-
- int attribute_number, truth_state, bitmask;
- uchar *attrbyte;
- do
- { truth_state = TRUE;
-
- ParseAttrN:
-
- get_next_token_with_directives();
- if ((token_type == SEGMENT_MARKER_TT)
- || (token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { if (!truth_state)
- ebf_error("attribute name after '~'", token_text);
- put_token_back(); return;
- }
- if ((token_type == SEP_TT) && (token_value == COMMA_SEP)) return;
-
- if ((token_type == SEP_TT) && (token_value == ARTNOT_SEP))
- { truth_state = !truth_state; goto ParseAttrN;
- }
-
- if ((token_type != SYMBOL_TT)
- || (stypes[token_value] != ATTRIBUTE_T))
- { ebf_error("name of an already-declared attribute", token_text);
- return;
- }
-
- attribute_number = svals[token_value];
- sflags[token_value] |= USED_SFLAG;
-
- if (!glulx_mode) {
- bitmask = (1 << (7-attribute_number%8));
- attrbyte = &(full_object.atts[attribute_number/8]);
- }
- else {
- /* In Glulx, my prejudices rule, and therefore bits are numbered
- from least to most significant. This is the opposite of the
- way the Z-machine works. */
- bitmask = (1 << (attribute_number%8));
- attrbyte = &(full_object_g.atts[attribute_number/8]);
- }
-
- if (truth_state)
- *attrbyte |= bitmask; /* Set attribute bit */
- else
- *attrbyte &= ~bitmask; /* Clear attribute bit */
-
- } while (TRUE);
-}
-
-/* ------------------------------------------------------------------------- */
-/* Classes ("class") segment. */
-/* ------------------------------------------------------------------------- */
-
-static void add_class_to_inheritance_list(int class_number)
-{
- int i;
-
- /* The class number is actually the class's object number, which needs
- to be translated into its actual class number: */
-
- for (i=0;i ... */
-
- do
- { get_next_token_with_directives();
- if ((token_type == SEGMENT_MARKER_TT)
- || (token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { put_token_back(); return;
- }
- if ((token_type == SEP_TT) && (token_value == COMMA_SEP)) return;
-
- if ((token_type != SYMBOL_TT)
- || (stypes[token_value] != CLASS_T))
- { ebf_error("name of an already-declared class", token_text);
- return;
- }
-
- sflags[token_value] |= USED_SFLAG;
- add_class_to_inheritance_list(svals[token_value]);
- } while (TRUE);
-}
-
-/* ------------------------------------------------------------------------- */
-/* Parse the body of a Nearby/Object/Class definition. */
-/* ------------------------------------------------------------------------- */
-
-static void parse_body_of_definition(void)
-{ int commas_in_row;
-
- def_t_s = 0;
-
- do
- { commas_in_row = -1;
- do
- { get_next_token_with_directives(); commas_in_row++;
- } while ((token_type == SEP_TT) && (token_value == COMMA_SEP));
-
- if (commas_in_row>1)
- error("Two commas ',' in a row in object/class definition");
-
- if ((token_type == EOF_TT)
- || ((token_type == SEP_TT) && (token_value == SEMICOLON_SEP)))
- { if (commas_in_row > 0)
- error("Object/class definition finishes with ','");
- if (token_type == EOF_TT)
- error("Object/class definition incomplete (no ';') at end of file");
- break;
- }
-
- if (token_type != SEGMENT_MARKER_TT)
- { error_named("Expected 'with', 'has' or 'class' in \
-object/class definition but found", token_text);
- break;
- }
- else
- switch(token_value)
- { case WITH_SEGMENT:
- properties_segment(WITH_SEGMENT);
- break;
- case PRIVATE_SEGMENT:
- properties_segment(PRIVATE_SEGMENT);
- break;
- case HAS_SEGMENT:
- attributes_segment();
- break;
- case CLASS_SEGMENT:
- classes_segment();
- break;
- }
-
- } while (TRUE);
-
-}
-
-/* ------------------------------------------------------------------------- */
-/* Class directives: */
-/* */
-/* Class */
-/* ------------------------------------------------------------------------- */
-
-static void initialise_full_object(void)
-{
- int i;
- if (!glulx_mode) {
- full_object.l = 0;
- full_object.atts[0] = 0;
- full_object.atts[1] = 0;
- full_object.atts[2] = 0;
- full_object.atts[3] = 0;
- full_object.atts[4] = 0;
- full_object.atts[5] = 0;
- }
- else {
- full_object_g.numprops = 0;
- full_object_g.propdatasize = 0;
- for (i=0; i10000))
- { error("The number of duplicates must be 0 to 10000");
- n=0;
- }
-
- /* Make one extra duplicate, since the veneer routines need
- always to keep an undamaged prototype for the class in stock */
-
- duplicates_to_make = n + 1;
-
- match_close_bracket();
- } else put_token_back();
-
- /* Parse the body of the definition: */
-
- parse_body_of_definition();
- }
-
- if (debugfile_switch)
- { debug_file_printf("");
- debug_file_printf("%s", shortname_buffer);
- debug_file_printf("%d", no_classes);
- debug_file_printf("");
- write_debug_object_backpatch(no_objects + 1);
- debug_file_printf("");
- write_debug_locations
- (get_token_location_end(beginning_debug_location));
- debug_file_printf("");
- }
-
- if (!glulx_mode)
- manufacture_object_z();
- else
- manufacture_object_g();
-
- if (individual_prop_table_size >= VENEER_CONSTRAINT_ON_IP_TABLE_SIZE)
- error("This class is too complex: it now carries too many properties. \
-You may be able to get round this by declaring some of its property names as \
-\"common properties\" using the 'Property' directive.");
-
- if (duplicates_to_make > 0)
- { sprintf(duplicate_name, "%s_1", shortname_buffer);
- for (n=1; (duplicates_to_make--) > 0; n++)
- { if (n>1)
- { int i = strlen(duplicate_name);
- while (duplicate_name[i] != '_') i--;
- sprintf(duplicate_name+i+1, "%d", n);
- }
- make_object(FALSE, duplicate_name, class_number, class_number, -1);
- }
- }
-}
-
-/* ------------------------------------------------------------------------- */
-/* Object/Nearby directives: */
-/* */
-/* Object ... "short name" [parent] */
-/* */
-/* Nearby ... "short name" */
-/* ------------------------------------------------------------------------- */
-
-static int end_of_header(void)
-{ if (((token_type == SEP_TT) && (token_value == SEMICOLON_SEP))
- || ((token_type == SEP_TT) && (token_value == COMMA_SEP))
- || (token_type == SEGMENT_MARKER_TT)) return TRUE;
- return FALSE;
-}
-
-extern void make_object(int nearby_flag,
- char *textual_name, int specified_parent, int specified_class,
- int instance_of)
-{
- /* Ordinarily this is called with nearby_flag TRUE for "Nearby",
- FALSE for "Object"; and textual_name NULL, specified_parent and
- specified_class both -1. The next three arguments are used when
- the routine is called for class duplicates manufacture (see above).
- The last is used to create instances of a particular class. */
-
- int i, tree_depth, internal_name_symbol = 0;
- char internal_name[64];
- debug_location_beginning beginning_debug_location =
- get_token_location_beginning();
-
- directives.enabled = FALSE;
-
- if (no_objects==MAX_OBJECTS) memoryerror("MAX_OBJECTS", MAX_OBJECTS);
-
- sprintf(internal_name, "nameless_obj__%d", no_objects+1);
- objectname_text = internal_name;
-
- current_defn_is_class = FALSE;
-
- no_classes_to_inherit_from=0;
-
- individual_prop_table_size = 0;
-
- if (nearby_flag) tree_depth=1; else tree_depth=0;
-
- if (specified_class != -1) goto HeaderPassed;
-
- get_next_token();
-
- /* Read past and count a sequence of "->"s, if any are present */
-
- if ((token_type == SEP_TT) && (token_value == ARROW_SEP))
- { if (nearby_flag)
- error("The syntax '->' is only used as an alternative to 'Nearby'");
-
- while ((token_type == SEP_TT) && (token_value == ARROW_SEP))
- { tree_depth++;
- get_next_token();
- }
- }
-
- sprintf(shortname_buffer, "?");
-
- segment_markers.enabled = TRUE;
-
- /* This first word is either an internal name, or a textual short name,
- or the end of the header part */
-
- if (end_of_header()) goto HeaderPassed;
-
- if (token_type == DQ_TT) textual_name = token_text;
- else
- { if ((token_type != SYMBOL_TT)
- || (!(sflags[token_value] & UNKNOWN_SFLAG)))
- ebf_error("name for new object or its textual short name",
- token_text);
- else
- { internal_name_symbol = token_value;
- strcpy(internal_name, token_text);
- }
- }
-
- /* The next word is either a parent object, or
- a textual short name, or the end of the header part */
-
- get_next_token_with_directives();
- if (end_of_header()) goto HeaderPassed;
-
- if (token_type == DQ_TT)
- { if (textual_name != NULL)
- error("Two textual short names given for only one object");
- else
- textual_name = token_text;
- }
- else
- { if ((token_type != SYMBOL_TT)
- || (sflags[token_value] & UNKNOWN_SFLAG))
- { if (textual_name == NULL)
- ebf_error("parent object or the object's textual short name",
- token_text);
- else
- ebf_error("parent object", token_text);
- }
- else goto SpecParent;
- }
-
- /* Finally, it's possible that there is still a parent object */
-
- get_next_token();
- if (end_of_header()) goto HeaderPassed;
-
- if (specified_parent != -1)
- ebf_error("body of object definition", token_text);
- else
- { SpecParent:
- if ((stypes[token_value] == OBJECT_T)
- || (stypes[token_value] == CLASS_T))
- { specified_parent = svals[token_value];
- sflags[token_value] |= USED_SFLAG;
- }
- else ebf_error("name of (the parent) object", token_text);
- }
-
- /* Now it really has to be the body of the definition. */
-
- get_next_token_with_directives();
- if (end_of_header()) goto HeaderPassed;
-
- ebf_error("body of object definition", token_text);
-
- HeaderPassed:
- if (specified_class == -1) put_token_back();
-
- if (internal_name_symbol > 0)
- assign_symbol(internal_name_symbol, no_objects + 1, OBJECT_T);
-
- if (listobjects_switch)
- printf("%3d \"%s\"\n", no_objects+1,
- (textual_name==NULL)?"(with no short name)":textual_name);
- if (textual_name == NULL)
- { if (internal_name_symbol > 0)
- sprintf(shortname_buffer, "(%s)",
- (char *) symbs[internal_name_symbol]);
- else
- sprintf(shortname_buffer, "(%d)", no_objects+1);
- }
- else
- { if (strlen(textual_name)>765)
- error("Short name of object (in quotes) exceeded 765 characters");
- strncpy(shortname_buffer, textual_name, 765);
- }
-
- if (specified_parent != -1)
- { if (tree_depth > 0)
- error("Use of '->' (or 'Nearby') clashes with giving a parent");
- parent_of_this_obj = specified_parent;
- }
- else
- { parent_of_this_obj = 0;
- if (tree_depth>0)
- {
- /* We have to set the parent object to the most recently defined
- object at level (tree_depth - 1) in the tree.
-
- A complication is that objects are numbered 1, 2, ... in the
- Z-machine (and in the objects[].parent, etc., fields) but
- 0, 1, 2, ... internally (and as indices to object[]). */
-
- for (i=no_objects-1; i>=0; i--)
- { int j = i, k = 0;
-
- /* Metaclass or class objects cannot be '->' parents: */
- if ((!module_switch) && (i<4))
- continue;
-
- if (!glulx_mode) {
- if (objectsz[i].parent == 1)
- continue;
- while (objectsz[j].parent != 0)
- { j = objectsz[j].parent - 1; k++; }
- }
- else {
- if (objectsg[i].parent == 1)
- continue;
- while (objectsg[j].parent != 0)
- { j = objectsg[j].parent - 1; k++; }
- }
-
- if (k == tree_depth - 1)
- { parent_of_this_obj = i+1;
- break;
- }
- }
- if (parent_of_this_obj == 0)
- { if (tree_depth == 1)
- error("'->' (or 'Nearby') fails because there is no previous object");
- else
- error("'-> -> ...' fails because no previous object is deep enough");
- }
- }
- }
-
- initialise_full_object();
- if (instance_of != -1) add_class_to_inheritance_list(instance_of);
-
- if (specified_class == -1) parse_body_of_definition();
- else add_class_to_inheritance_list(specified_class);
-
- if (debugfile_switch)
- { debug_file_printf("");
- }
-
- if (!glulx_mode)
- manufacture_object_z();
- else
- manufacture_object_g();
-}
-
-/* ========================================================================= */
-/* Data structure management routines */
-/* ------------------------------------------------------------------------- */
-
-extern void init_objects_vars(void)
-{
- properties_table = NULL;
- prop_is_long = NULL;
- prop_is_additive = NULL;
- prop_default_value = NULL;
-
- objectsz = NULL;
- objectsg = NULL;
- objectatts = NULL;
- classes_to_inherit_from = NULL;
- class_begins_at = NULL;
-}
-
-extern void objects_begin_pass(void)
-{
- properties_table_size=0;
- prop_is_long[1] = TRUE; prop_is_additive[1] = TRUE; /* "name" */
- prop_is_long[2] = TRUE; prop_is_additive[2] = TRUE; /* inheritance prop */
- if (!glulx_mode)
- prop_is_long[3] = TRUE; prop_is_additive[3] = FALSE;
- /* instance variables table address */
- no_properties = 4;
-
- if (debugfile_switch)
- { debug_file_printf("");
- debug_file_printf
- ("inheritance class");
- debug_file_printf("2");
- debug_file_printf("");
- debug_file_printf("");
- debug_file_printf
- ("instance variables table address "
- "(Z-code)");
- debug_file_printf("3");
- debug_file_printf("");
- }
-
- if (define_INFIX_switch) no_attributes = 1;
- else no_attributes = 0;
-
- no_objects = 0;
- if (!glulx_mode) {
- objectsz[0].parent = 0; objectsz[0].child = 0; objectsz[0].next = 0;
- no_individual_properties=72;
- }
- else {
- objectsg[0].parent = 0; objectsg[0].child = 0; objectsg[0].next = 0;
- no_individual_properties = INDIV_PROP_START+8;
- }
- no_classes = 0;
-
- no_embedded_routines = 0;
-
- individuals_length=0;
-}
-
-extern void objects_allocate_arrays(void)
-{
- objectsz = NULL;
- objectsg = NULL;
- objectatts = NULL;
-
- prop_default_value = my_calloc(sizeof(int32), INDIV_PROP_START,
- "property default values");
- prop_is_long = my_calloc(sizeof(int), INDIV_PROP_START,
- "property-is-long flags");
- prop_is_additive = my_calloc(sizeof(int), INDIV_PROP_START,
- "property-is-additive flags");
-
- classes_to_inherit_from = my_calloc(sizeof(int), MAX_CLASSES,
- "inherited classes list");
- class_begins_at = my_calloc(sizeof(int32), MAX_CLASSES,
- "pointers to classes");
- class_object_numbers = my_calloc(sizeof(int), MAX_CLASSES,
- "class object numbers");
-
- properties_table = my_malloc(MAX_PROP_TABLE_SIZE,"properties table");
- individuals_table = my_malloc(MAX_INDIV_PROP_TABLE_SIZE,
- "individual properties table");
-
- defined_this_segment_size = 128;
- defined_this_segment = my_calloc(sizeof(int), defined_this_segment_size,
- "defined this segment table");
-
- if (!glulx_mode) {
- objectsz = my_calloc(sizeof(objecttz), MAX_OBJECTS,
- "z-objects");
- }
- else {
- objectsg = my_calloc(sizeof(objecttg), MAX_OBJECTS,
- "g-objects");
- objectatts = my_calloc(NUM_ATTR_BYTES, MAX_OBJECTS,
- "g-attributes");
- full_object_g.props = my_calloc(sizeof(propg), MAX_OBJ_PROP_COUNT,
- "object property list");
- full_object_g.propdata = my_calloc(sizeof(assembly_operand),
- MAX_OBJ_PROP_TABLE_SIZE,
- "object property data table");
- }
-}
-
-extern void objects_free_arrays(void)
-{
- my_free(&prop_default_value, "property default values");
- my_free(&prop_is_long, "property-is-long flags");
- my_free(&prop_is_additive, "property-is-additive flags");
-
- my_free(&objectsz, "z-objects");
- my_free(&objectsg, "g-objects");
- my_free(&objectatts, "g-attributes");
- my_free(&class_object_numbers,"class object numbers");
- my_free(&classes_to_inherit_from, "inherited classes list");
- my_free(&class_begins_at, "pointers to classes");
-
- my_free(&properties_table, "properties table");
- my_free(&individuals_table,"individual properties table");
-
- my_free(&defined_this_segment,"defined this segment table");
-
- if (!glulx_mode) {
- my_free(&full_object_g.props, "object property list");
- my_free(&full_object_g.propdata, "object property data table");
- }
-
-}
-
-/* ========================================================================= */