Diff | Source/Git

Download diff

	4b825dc642cb6eb9a060e54bf8d69288fbee4904		cfad47cfa334b206c65f22086bcc5d63e6f70944
		1	#ifdef RCSID
		2	static char RCSid[] =
		3	"$Header: d:/cvsroot/tads/tads3/VMTOBJ.CPP,v 1.3 1999/05/17 02:52:28 MJRoberts Exp $";
		4	#endif
		5
		6	/*
		7	* Copyright (c) 1998, 2002 Michael J. Roberts. All Rights Reserved.
		8	*
		9	* Please see the accompanying license file, LICENSE.TXT, for information
		10	* on using and copying this software.
		11	*/
		12	/*
		13	Name
		14	vmtobj.cpp - TADS object implementation
		15	Function
		16
		17	Notes
		18
		19	Modified
		20	10/30/98 MJRoberts - Creation
		21	*/
		22
		23	#include <stdlib.h>
		24	#include <assert.h>
		25
		26	#include "t3std.h"
		27	#include "vmglob.h"
		28	#include "vmerr.h"
		29	#include "vmerrnum.h"
		30	#include "vmobj.h"
		31	#include "vmtobj.h"
		32	#include "vmundo.h"
		33	#include "vmtype.h"
		34	#include "vmfile.h"
		35	#include "vmstack.h"
		36	#include "vmrun.h"
		37	#include "vmpredef.h"
		38	#include "vmmeta.h"
		39	#include "vmlst.h"
		40	#include "vmintcls.h"
		41
		42
		43	/* ------------------------------------------------------------------------ */
		44	/*
		45	* object ID + pointer structure
		46	*/
		47	struct tadsobj_objid_and_ptr
		48	{
		49	vm_obj_id_t id;
		50	CVmObjTads *objp;
		51	};
		52
		53	/*
		54	* Cached superclass inheritance path. This is a linear list, in
		55	* inheritance search order, of the superclasses of a given object.
		56	*/
		57	struct tadsobj_inh_path
		58	{
		59	/* number of path elements */
		60	ushort cnt;
		61
		62	/* path elements (we overallocate the structure to the actual size) */
		63	tadsobj_objid_and_ptr sc[1];
		64	};
		65
		66
		67	/* ------------------------------------------------------------------------ */
		68	/*
		69	* Queue element for the inheritance path search queue
		70	*/
		71	struct pfq_ele
		72	{
		73	/* object ID of this element */
		74	vm_obj_id_t obj;
		75
		76	/* pointer to the object */
		77	CVmObjTads *objp;
		78
		79	/* next queue element */
		80	pfq_ele *nxt;
		81	};
		82
		83	/* allocation page */
		84	struct pfq_page
		85	{
		86	/* next page in the list */
		87	pfq_page *nxt;
		88
		89	/* the elements for this page */
		90	pfq_ele eles[50];
		91	};
		92
		93	/*
		94	* Queue for search_for_prop(). This implements a special-purpose work
		95	* queue that we use to keep track of the objects yet to be processed in
		96	* our depth-first search across the inheritance tree.
		97	*/
		98	class CVmObjTadsInhQueue
		99	{
		100	public:
		101	CVmObjTadsInhQueue()
		102	{
		103	/* there's nothing in the free list or the queue yet */
		104	head_ = 0;
		105	free_ = 0;
		106
		107	/* we have no elements yet */
		108	alloc_ = 0;
		109	}
		110
		111	~CVmObjTadsInhQueue()
		112	{
		113	pfq_page *cur;
		114	pfq_page *nxt;
		115
		116	/* delete all of the allocated pages */
		117	for (cur = alloc_ ; cur != 0 ; cur = nxt)
		118	{
		119	/* remember the next page */
		120	nxt = cur->nxt;
		121
		122	/* free this page */
		123	t3free(cur);
		124	}
		125	}
		126
		127	/* get the head of the queue */
		128	pfq_ele *get_head() const { return head_; }
		129
		130	/* remove the head of the queue and return the object ID */
		131	vm_obj_id_t remove_head()
		132	{
		133	/* if there's a head element, remove it */
		134	if (head_ != 0)
		135	{
		136	pfq_ele *ele;
		137
		138	/* note the element */
		139	ele = head_;
		140
		141	/* unlink it from the list */
		142	head_ = head_->nxt;
		143
		144	/* link the element into the free list */
		145	ele->nxt = free_;
		146	free_ = ele;
		147
		148	/* return the object ID from the element we removed */
		149	return ele->obj;
		150	}
		151	else
		152	{
		153	/* there's nothing in the queue */
		154	return VM_INVALID_OBJ;
		155	}
		156	}
		157
		158	/* clear the queue */
		159	void clear()
		160	{
		161	/* move everything from the queue to the free list */
		162	while (head_ != 0)
		163	{
		164	pfq_ele *cur;
		165
		166	/* unlink this element from the queue */
		167	cur = head_;
		168	head_ = cur->nxt;
		169
		170	/* link it into the free list */
		171	cur->nxt = free_;
		172	free_ = cur;
		173	}
		174	}
		175
		176	/* determine if the queue is empty */
		177	int is_empty() const
		178	{
		179	/* we're empty if there's no head element in the list */
		180	return (head_ == 0);
		181	}
		182
		183	/* allocate a path from the contents of the queue */
		184	tadsobj_inh_path *create_path() const
		185	{
		186	ushort cnt;
		187	pfq_ele *cur;
		188	tadsobj_inh_path *path;
		189	tadsobj_objid_and_ptr *dst;
		190
		191	/* count the elements in the queue */
		192	for (cnt = 0, cur = head_ ; cur != 0 ; cur = cur->nxt)
		193	{
		194	/* only non-nil elements count */
		195	if (cur->obj != VM_INVALID_OBJ)
		196	++cnt;
		197	}
		198
		199	/* allocate the path */
		200	path = (tadsobj_inh_path *)t3malloc(
		201	sizeof(tadsobj_inh_path) + (cnt-1)*sizeof(path->sc[0]));
		202
		203	/* initialize the path */
		204	path->cnt = cnt;
		205	for (dst = path->sc, cur = head_ ; cur != 0 ; cur = cur->nxt)
		206	{
		207	/* only store non-nil elements */
		208	if (cur->obj != VM_INVALID_OBJ)
		209	{
		210	dst->id = cur->obj;
		211	dst->objp = cur->objp;
		212	++dst;
		213	}
		214	}
		215
		216	/* return the new path */
		217	return path;
		218	}
		219
		220	/*
		221	* Insert an object into the queue. We'll insert after the given
		222	* element (null indicates that we insert at the head of the queue).
		223	* Returns a pointer to the newly-inserted element.
		224	*/
		225	pfq_ele insert_obj(VMG_ vm_obj_id_t obj, CVmObjTads objp,
		226	pfq_ele *ins_pt)
		227	{
		228	pfq_ele *ele;
		229
		230	/*
		231	* If the exact same element is already in the queue, delete the
		232	* old copy. This will happen in situations where we have
		233	* multiple superclasses that all inherit from a common base
		234	* class: we want the common base class to come in inheritance
		235	* order after the last superclass that inherits from the common
		236	* base. By deleting previous queue entries that match new queue
		237	* entries, we ensure that the common class will move to follow
		238	* (in inheritance order) the last class that derives from it.
		239	*/
		240	for (ele = head_ ; ele != 0 ; ele = ele->nxt)
		241	{
		242	/* if this is the same thing we're inserting, remove it */
		243	if (ele->obj == obj)
		244	{
		245	/*
		246	* clear the element (don't unlink it, as this could cause
		247	* confusion for the caller, who's tracking an insertion
		248	* point and traversal point)
		249	*/
		250	ele->obj = VM_INVALID_OBJ;
		251	ele->objp = 0;
		252
		253	/*
		254	* no need to look any further - we know we can never have
		255	* the same element appear twice in the queue, thanks to
		256	* this very code
		257	*/
		258	break;
		259	}
		260	}
		261
		262	/* allocate our new element */
		263	ele = alloc_ele();
		264	ele->obj = obj;
		265	ele->objp = objp;
		266
		267	/* insert it at the insertion point */
		268	if (ins_pt == 0)
		269	{
		270	/* insert at the head */
		271	ele->nxt = head_;
		272	head_ = ele;
		273	}
		274	else
		275	{
		276	/* insert after the selected item */
		277	ele->nxt = ins_pt->nxt;
		278	ins_pt->nxt = ele;
		279	}
		280
		281	/* return the new element */
		282	return ele;
		283	}
		284
		285	protected:
		286	/* allocate a new element */
		287	pfq_ele *alloc_ele()
		288	{
		289	pfq_ele *ele;
		290
		291	/* if we have nothing in the free list, allocate more elements */
		292	if (free_ == 0)
		293	{
		294	pfq_page *pg;
		295	size_t i;
		296
		297	/* allocate another page */
		298	pg = (pfq_page *)t3malloc(sizeof(pfq_page));
		299
		300	/* link it into our master page list */
		301	pg->nxt = alloc_;
		302	alloc_ = pg;
		303
		304	/* link all of its elements into the free list */
		305	for (ele = pg->eles, i = sizeof(pg->eles)/sizeof(pg->eles[0]) ;
		306	i != 0 ; --i, ++ele)
		307	{
		308	/* link this one into the free list */
		309	ele->nxt = free_;
		310	free_ = ele;
		311	}
		312	}
		313
		314	/* take the next element off the free list */
		315	ele = free_;
		316	free_ = free_->nxt;
		317
		318	/* return the element */
		319	return ele;
		320	}
		321
		322	/* head of the active queue */
		323	pfq_ele *head_;
		324
		325	/* head of the free element list */
		326	pfq_ele *free_;
		327
		328	/*
		329	* Linked list of element pages. We allocate memory for elements in
		330	* blocks, to reduce allocation overhead.
		331	*/
		332	pfq_page *alloc_;
		333	};
		334
		335
		336	/* ------------------------------------------------------------------------ */
		337	/*
		338	* Allocate a new object header
		339	*/
		340	vm_tadsobj_hdr vm_tadsobj_hdr::alloc(VMG_ CVmObjTads self,
		341	unsigned short sc_cnt,
		342	unsigned short prop_cnt)
		343	{
		344	ushort hash_siz;
		345	size_t siz;
		346	size_t i;
		347	vm_tadsobj_hdr *hdr;
		348	char *mem;
		349	vm_tadsobj_prop **hashp;
		350
		351	/*
		352	* Figure the size of the hash table to allocate.
		353	*
		354	* IMPORTANT: The hash table size is REQUIRED to be a power of 2. We
		355	* assume this in calculating hash table indices, so if this
		356	* constraint is changed, the calc_hash() function must be changed
		357	* accordingly.
		358	*/
		359	if (prop_cnt <= 16)
		360	hash_siz = 16;
		361	else if (prop_cnt <= 32)
		362	hash_siz = 32;
		363	else if (prop_cnt <= 64)
		364	hash_siz = 64;
		365	else if (prop_cnt <= 128)
		366	hash_siz = 128;
		367	else
		368	hash_siz = 256;
		369
		370	/*
		371	* increase the requested property count to the hash size at a minimum
		372	* - this will avoid the need to reallocate the object to make room
		373	* for more properties until we'd have to resize the hash table, at
		374	* which point we have to reallocate the object anyway
		375	*/
		376	if (prop_cnt < hash_siz)
		377	prop_cnt = hash_siz;
		378
		379	/* figure the size of the structure we need */
		380	siz = sizeof(vm_tadsobj_hdr)
		381	+ (sc_cnt - 1) * sizeof(hdr->sc[0])
		382	+ (hash_siz) * sizeof(hdr->hash_arr[0])
		383	+ prop_cnt * sizeof(hdr->prop_entry_arr[0]);
		384
		385	/* allocate the memory */
		386	hdr = (vm_tadsobj_hdr *)G_mem->get_var_heap()->alloc_mem(siz, self);
		387
		388	/*
		389	* Set up to suballocate out of this block. Free memory in the block
		390	* starts after our structure and the array of superclass entries.
		391	*/
		392	mem = (char *)&hdr->sc[sc_cnt];
		393
		394	/* clear our flags and load-image flags */
		395	hdr->li_obj_flags = 0;
		396	hdr->intern_obj_flags = 0;
		397
		398	/* the object has no precalculated inheritance path yet */
		399	hdr->inh_path = 0;
		400
		401	/* suballocate the hash buckets */
		402	hdr->hash_siz = hash_siz;
		403	hdr->hash_arr = (vm_tadsobj_prop **)mem;
		404
		405	/* clear out the hash buckets */
		406	for (hashp = hdr->hash_arr, i = hash_siz ; i != 0 ; ++hashp, --i)
		407	*hashp = 0;
		408
		409	/* move past the memory taken by the hash buckets */
		410	mem = (char *)(hdr->hash_arr + hash_siz);
		411
		412	/* suballocate the array of hash entries */
		413	hdr->prop_entry_cnt = prop_cnt;
		414	hdr->prop_entry_arr = (vm_tadsobj_prop *)mem;
		415
		416	/* all entries are currently free, so point to the first entry */
		417	hdr->prop_entry_free = 0;
		418
		419	/* remember the superclass count */
		420	hdr->sc_cnt = sc_cnt;
		421
		422	/* return the new object */
		423	return hdr;
		424	}
		425
		426	/*
		427	* Free
		428	*/
		429	void vm_tadsobj_hdr::free_mem()
		430	{
		431	/* if I have a precalculated inheritance path, delete it */
		432	if (inh_path != 0)
		433	t3free(inh_path);
		434	}
		435
		436	/*
		437	* Expand an existing object header to make room for more properties
		438	*/
		439	vm_tadsobj_hdr vm_tadsobj_hdr::expand(VMG_ CVmObjTads self,
		440	vm_tadsobj_hdr *hdr)
		441	{
		442	unsigned short prop_cnt;
		443
		444	/*
		445	* Move up to the next property count increment. If we're not huge,
		446	* simply double the current size. If we're getting large, expand by
		447	* 50%.
		448	*/
		449	prop_cnt = hdr->prop_entry_cnt;
		450	if (prop_cnt <= 128)
		451	prop_cnt *= 2;
		452	else
		453	prop_cnt += prop_cnt/2;
		454
		455	/* expand to the new size */
		456	return expand_to(vmg_ self, hdr, hdr->sc_cnt, prop_cnt);
		457	}
		458
		459	/*
		460	* Expand an existing header to the given minimum property table size
		461	*/
		462	vm_tadsobj_hdr vm_tadsobj_hdr::expand_to(VMG_ CVmObjTads self,
		463	vm_tadsobj_hdr *hdr,
		464	size_t new_sc_cnt,
		465	size_t new_prop_cnt)
		466	{
		467	vm_tadsobj_hdr *new_hdr;
		468	size_t i;
		469	vm_tadsobj_prop *entryp;
		470
		471	/* allocate a new object at the expanded property table size */
		472	new_hdr = alloc(vmg_ self, (ushort)new_sc_cnt, (ushort)new_prop_cnt);
		473
		474	/* copy the superclasses from the original object */
		475	memcpy(new_hdr->sc, hdr->sc,
		476	(hdr->sc_cnt < new_sc_cnt ? hdr->sc_cnt : new_sc_cnt)
		477	* sizeof(hdr->sc[0]));
		478
		479	/* use the same flags from the original object */
		480	new_hdr->li_obj_flags = hdr->li_obj_flags;
		481	new_hdr->intern_obj_flags = hdr->intern_obj_flags;
		482
		483	/*
		484	* if the superclass count is changing, we're obviously changing the
		485	* inheritance structure, in which case the old cached inheritance path
		486	* is invalid - delete it if so
		487	*/
		488	if (new_sc_cnt != hdr->sc_cnt)
		489	hdr->inval_inh_path();
		490
		491	/* copy the old inheritance path (if we still have one) */
		492	new_hdr->inh_path = hdr->inh_path;
		493
		494	/*
		495	* Run through all of the existing properties and duplicate them in the
		496	* new object, to build the new object's hash table. Note that the
		497	* free index is inherently equivalent to the count of properties in
		498	* use.
		499	*/
		500	for (i = hdr->prop_entry_free, entryp = hdr->prop_entry_arr ; i != 0 ;
		501	--i, ++entryp)
		502	{
		503	/* add this property to the new table */
		504	new_hdr->alloc_prop_entry(entryp->prop, &entryp->val, entryp->flags);
		505	}
		506
		507	/* delete the old header */
		508	G_mem->get_var_heap()->free_mem(hdr);
		509
		510	/* return the new header */
		511	return new_hdr;
		512	}
		513
		514	/*
		515	* Allocate an entry for given property from the free pool. The caller is
		516	* responsible for checking that there's space in the free pool. We do
		517	* not check for an existing entry with the same caller ID, so the caller
		518	* is responsible for making sure the property doesn't already exist in
		519	* our table.
		520	*/
		521	vm_tadsobj_prop *vm_tadsobj_hdr::alloc_prop_entry(
		522	vm_prop_id_t prop, const vm_val_t *val, unsigned int flags)
		523	{
		524	vm_tadsobj_prop *entry;
		525	unsigned int hash;
		526
		527	/* get the hash code for the property */
		528	hash = calc_hash(prop);
		529
		530	/* use the next free entry */
		531	entry = &prop_entry_arr[prop_entry_free];
		532
		533	/* link this entry into the list for its hash bucket */
		534	entry->nxt = hash_arr[hash];
		535	hash_arr[hash] = entry;
		536
		537	/* count our use of the free entry */
		538	++prop_entry_free;
		539
		540	/* set the new entry's property ID */
		541	entry->prop = prop;
		542
		543	/* set the value and flags */
		544	entry->val = *val;
		545	entry->flags = (unsigned char)flags;
		546
		547	/* return the entry */
		548	return entry;
		549	}
		550
		551	/*
		552	* Find an entry
		553	*/
		554	inline vm_tadsobj_prop *vm_tadsobj_hdr::find_prop_entry(uint prop)
		555	{
		556	unsigned int hash;
		557	vm_tadsobj_prop *entry;
		558
		559	/* get the hash code for the property */
		560	hash = calc_hash(prop);
		561
		562	/* scan the list of entries in this bucket */
		563	for (entry = hash_arr[hash] ; entry != 0 ; entry = entry->nxt)
		564	{
		565	/* if this entry matches, return it */
		566	if (entry->prop == prop)
		567	return entry;
		568	}
		569
		570	/* didn't find it */
		571	return 0;
		572	}
		573
		574
		575	/* ------------------------------------------------------------------------ */
		576	/*
		577	* statics
		578	*/
		579
		580	/* metaclass registration object */
		581	static CVmMetaclassTads metaclass_reg_obj;
		582	CVmMetaclass *CVmObjTads::metaclass_reg_ = &metaclass_reg_obj;
		583
		584
		585	/* function table */
		586	int (CVmObjTads::
		587	*CVmObjTads::func_table_[])(VMG_ vm_obj_id_t self,
		588	vm_val_t retval, uint argc) =
		589	{
		590	&CVmObjTads::getp_undef,
		591	&CVmObjTads::getp_create_instance,
		592	&CVmObjTads::getp_create_clone,
		593	&CVmObjTads::getp_create_trans_instance,
		594	&CVmObjTads::getp_create_instance_of,
		595	&CVmObjTads::getp_create_trans_instance_of,
		596	&CVmObjTads::getp_set_sc_list
		597	};
		598
		599	/*
		600	* Function table indices. We only need constant definitions for these
		601	* for our static methods, since in other cases we translate through the
		602	* function table.
		603	*/
		604	const int PROPIDX_CREATE_INSTANCE = 1;
		605	const int PROPIDX_CREATE_CLONE = 2;
		606	const int PROPIDX_CREATE_TRANS_INSTANCE = 3;
		607	const int PROPIDX_CREATE_INSTANCE_OF = 4;
		608	const int PROPIDX_CREATE_TRANS_INSTANCE_OF = 5;
		609
		610	/* ------------------------------------------------------------------------ */
		611	/*
		612	* Static class initialization
		613	*/
		614	void CVmObjTads::class_init(VMG0_)
		615	{
		616	/* allocate the inheritance analysis object */
		617	G_tadsobj_queue = new CVmObjTadsInhQueue();
		618	}
		619
		620	/*
		621	* Static class termination
		622	*/
		623	void CVmObjTads::class_term(VMG0_)
		624	{
		625	/* delete the inheritance analysis object */
		626	delete G_tadsobj_queue;
		627	G_tadsobj_queue = 0;
		628	}
		629
		630	/* ------------------------------------------------------------------------ */
		631	/*
		632	* Static creation methods
		633	*/
		634
		635	/* create dynamically using stack arguments */
		636	vm_obj_id_t CVmObjTads::create_from_stack_intern(
		637	VMG_ const uchar **pc_ptr, uint argc, int is_transient)
		638	{
		639	vm_obj_id_t id;
		640	CVmObjTads *obj;
		641	vm_val_t val;
		642	vm_obj_id_t srcobj;
		643
		644	/* check arguments */
		645	if (argc == 0)
		646	{
		647	/* no superclass argument - create a base object */
		648	val.set_nil();
		649	}
		650	else
		651	{
		652	/*
		653	* We have arguments. The first is the superclass argument, which
		654	* must be an object or nil. Retrieve it and make sure it's
		655	* valid.
		656	*/
		657	G_stk->pop(&val);
		658	if (val.typ != VM_OBJ && val.typ != VM_NIL)
		659	err_throw(VMERR_OBJ_VAL_REQD_SC);
		660
		661	/* if it's the invalid object, treat it as nil */
		662	if (val.typ == VM_OBJ && val.val.obj == VM_INVALID_OBJ)
		663	val.set_nil();
		664
		665	/* we cannot create an instance of a transient object */
		666	if (val.typ != VM_NIL
		667	&& G_obj_table->is_obj_transient(val.val.obj))
		668	err_throw(VMERR_BAD_DYNAMIC_NEW);
		669
		670	/* count the removal of the first argument */
		671	--argc;
		672	}
		673
		674	/*
		675	* create the object - this type of construction is never used for
		676	* root set objects
		677	*/
		678	id = vm_new_id(vmg_ FALSE, TRUE, FALSE);
		679
		680	/* make the object transient if desired */
		681	if (is_transient)
		682	G_obj_table->set_obj_transient(id);
		683
		684	/*
		685	* create a TADS object with the appropriate number of superclasses
		686	* (0 if no superclass was specified, 1 if one was), and the default
		687	* number of initial mutable properties
		688	*/
		689	obj = new (vmg_ id) CVmObjTads(vmg_ (val.typ == VM_NIL ? 0 : 1),
		690	VMTOBJ_PROP_INIT);
		691
		692	/* set the object's superclass */
		693	if (val.typ != VM_NIL)
		694	obj->set_sc(vmg_ 0, val.val.obj);
		695
		696	/*
		697	* Invoke the object's "construct" method, passing it the arguments
		698	* that are still on the stack. If the new object doesn't define or
		699	* inherit the "construct" method, simply push the new object
		700	* reference onto the stack directly.
		701	*/
		702	if (obj->get_prop(vmg_ G_predef->obj_construct, &val, id, &srcobj, 0))
		703	{
		704	vm_val_t srcobj_val;
		705	vm_val_t id_val;
		706	const uchar *dummy_pc_ptr;
		707	uint caller_ofs;
		708
		709	/* use the null PC pointer if the caller didn't supply one */
		710	if (pc_ptr == 0)
		711	{
		712	/* there's no caller PC pointer - use a dummy value */
		713	pc_ptr = &dummy_pc_ptr;
		714	caller_ofs = 0;
		715	}
		716	else
		717	{
		718	/* get the caller's offset */
		719	caller_ofs = G_interpreter->pc_to_method_ofs(*pc_ptr);
		720	}
		721
		722	/*
		723	* A "construct" method is defined - have the interpreter invoke
		724	* it, which will set up the interpreter to start executing its
		725	* byte-code. This is all we need to do, since we assume and
		726	* require that the constructor will return the new object as
		727	* its return value when it's done.
		728	*/
		729	srcobj_val.set_obj(srcobj);
		730	id_val.set_obj(id);
		731	*pc_ptr = G_interpreter->get_prop(vmg_ caller_ofs, &srcobj_val,
		732	G_predef->obj_construct,
		733	&id_val, argc);
		734	}
		735	else
		736	{
		737	/*
		738	* there's no "construct" method defined - if we have any
		739	* arguments, its an error
		740	*/
		741	if (argc != 0)
		742	err_throw(VMERR_WRONG_NUM_OF_ARGS);
		743
		744	/* leave the new object value in R0 */
		745	G_interpreter->get_r0()->set_obj(id);
		746	}
		747
		748	/* return the new object */
		749	return id;
		750	}
		751
		752	/* create an object with no initial extension */
		753	vm_obj_id_t CVmObjTads::create(VMG_ int in_root_set)
		754	{
		755	vm_obj_id_t id = vm_new_id(vmg_ in_root_set, TRUE, FALSE);
		756	new (vmg_ id) CVmObjTads();
		757	return id;
		758	}
		759
		760	/*
		761	* Create an object with a given number of superclasses, and a given
		762	* property table size. Each superclass must be set before the object
		763	* can be used, and the property table is initially empty.
		764	*
		765	* This form is used to create objects dynamically; this call is never
		766	* used to load an object from an image file.
		767	*/
		768	vm_obj_id_t CVmObjTads::create(VMG_ int in_root_set,
		769	ushort superclass_count, ushort prop_count)
		770	{
		771	vm_obj_id_t id = vm_new_id(vmg_ in_root_set, TRUE, FALSE);
		772	new (vmg_ id) CVmObjTads(vmg_ superclass_count, prop_count);
		773	return id;
		774	}
		775
		776	/*
		777	* Create an instance based on multiple superclasses, using the
		778	* createInstanceOf() interface. Arguments are passed on the stack. Each
		779	* argument gives a superclass, and optionally the arguments for its
		780	* inherited constructor. If an argument is a simple object/class, then we
		781	* won't inherit that object's constructor at all. If an argument is a
		782	* list, then the first element of the list gives the class, and the
		783	* remaining elements of the list give the arguments to pass to that
		784	* class's inherited constructor.
		785	*/
		786	vm_obj_id_t CVmObjTads::create_from_stack_multi(
		787	VMG_ uint argc, int is_transient)
		788	{
		789	vm_obj_id_t id;
		790	CVmObjTads *obj;
		791	ushort i;
		792
		793	/* allocate an object ID */
		794	id = vm_new_id(vmg_ FALSE, TRUE, FALSE);
		795	if (is_transient)
		796	G_obj_table->set_obj_transient(id);
		797
		798	/* create the new object */
		799	obj = new (vmg_ id) CVmObjTads(vmg_ (ushort)argc, VMTOBJ_PROP_INIT);
		800
		801	/* push the new object, for garbage collector protection */
		802	G_interpreter->push_obj(vmg_ id);
		803
		804	/* set the superclasses */
		805	for (i = 0 ; i < argc ; ++i)
		806	{
		807	vm_val_t *arg;
		808	vm_val_t sc;
		809	const char *lstp;
		810
		811	/*
		812	* get this argument (it's at i+1 because of the extra item we
		813	* pushed for gc protection)
		814	*/
		815	arg = G_stk->get(i + 1);
		816
		817	/*
		818	* if it's a list, the superclass is the first element; otherwise,
		819	* the argument is the superclass
		820	*/
		821	if ((lstp = arg->get_as_list(vmg0_)) != 0)
		822	{
		823	/* it's a list - the first element is the superclass */
		824	CVmObjList::index_list(vmg_ &sc, lstp, 1);
		825	}
		826	else
		827	{
		828	/* not a list - the argument is the superclass */
		829	sc = *arg;
		830	}
		831
		832	/* make sure it's a TadsObject */
		833	if (sc.typ != VM_OBJ \|\| !is_tadsobj_obj(vmg_ sc.val.obj))
		834	err_throw(VMERR_BAD_TYPE_BIF);
		835
		836	/* can't create an instance of a transient object */
		837	if (G_obj_table->is_obj_transient(sc.val.obj))
		838	err_throw(VMERR_BAD_DYNAMIC_NEW);
		839
		840	/* set this superclass */
		841	obj->set_sc(vmg_ i, sc.val.obj);
		842	}
		843
		844	/*
		845	* The new object is ready to go. All that remains is invoking any
		846	* inherited construtors that the caller wants us to invoked.
		847	* Constructor invocation is indicated by passing a list argument for
		848	* the corresponding superclass, so run through the arguments and
		849	* invoke each indicated constructor.
		850	*/
		851	for (i = 0 ; i < argc ; ++i)
		852	{
		853	vm_val_t *arg;
		854	vm_val_t sc;
		855	const char *lstp;
		856	uint lst_cnt;
		857	uint j;
		858	vm_val_t new_obj_val;
		859
		860	/* get the next argument */
		861	arg = G_stk->get(i + 1);
		862
		863	/* if it's not a list, we don't want to invoke this constructor */
		864	if ((lstp = arg->get_as_list(vmg0_)) == 0)
		865	{
		866	/* no constructor call is wanted - just keep going */
		867	continue;
		868	}
		869
		870	/* get the superclass from the list */
		871	CVmObjList::index_list(vmg_ &sc, lstp, 1);
		872
		873	/* get the number of list elements */
		874	lst_cnt = vmb_get_len(lstp);
		875
		876	/* make sure we have room to push the arguments */
		877	if (!G_stk->check_space(lst_cnt - 1))
		878	err_throw(VMERR_STACK_OVERFLOW);
		879
		880	/*
		881	* push the list elements in reverse order; don't push the first
		882	* element, since it's the superclass itself rather than an
		883	* argument to the constructor
		884	*/
		885	for (j = lst_cnt ; j > 1 ; --j)
		886	CVmObjList::index_and_push(vmg_ lstp, j);
		887
		888	/*
		889	* Invoke the constructor via a recursive call into the VM. Note
		890	* that we're inheriting the property, so 'self' is the new object,
		891	* but the 'target' object is the superclass whose constructor
		892	* we're invoking.
		893	*/
		894	new_obj_val.set_obj(id);
		895	G_interpreter->get_prop(vmg_ 0, &sc, G_predef->obj_construct,
		896	&new_obj_val, lst_cnt - 1);
		897	}
		898
		899	/* discard the arguments plus our own gc protection */
		900	G_stk->discard(argc + 1);
		901
		902	/* return the new object */
		903	return id;
		904	}
		905
		906	/* ------------------------------------------------------------------------ */
		907	/*
		908	* Constructors
		909	*/
		910
		911	/*
		912	* Create an object with a given number of superclasses, and a given
		913	* property table size. The superclasses must be individually set
		914	* before the object can be used, and the property table is initially
		915	* empty.
		916	*
		917	* This constructor is used only when creating a new object dynamically,
		918	* and is never used to load an object from an image file.
		919	*/
		920	CVmObjTads::CVmObjTads(VMG_ ushort superclass_count, ushort prop_count)
		921	{
		922	/* allocate our header */
		923	ext_ = (char *)vm_tadsobj_hdr::alloc(vmg_ this, superclass_count,
		924	prop_count);
		925	}
		926
		927
		928	/* ------------------------------------------------------------------------ */
		929	/*
		930	* receive notification of deletion
		931	*/
		932	void CVmObjTads::notify_delete(VMG_ int in_root_set)
		933	{
		934	/* free our extension */
		935	if (ext_ != 0)
		936	{
		937	/* tell the header to delete its memory */
		938	get_hdr()->free_mem();
		939
		940	/* delete the extension */
		941	G_mem->get_var_heap()->free_mem(ext_);
		942	}
		943	}
		944
		945	/* ------------------------------------------------------------------------ */
		946	/*
		947	* Create an instance of this class
		948	*/
		949	void CVmObjTads::create_instance(VMG_ vm_obj_id_t self,
		950	const uchar **pc_ptr, uint argc)
		951	{
		952	/* push myself as the superclass */
		953	G_stk->push()->set_obj(self);
		954
		955	/* use the normal stack creation routine */
		956	create_from_stack(vmg_ pc_ptr, argc+1);
		957	}
		958
		959	/* ------------------------------------------------------------------------ */
		960	/*
		961	* Determine if the object has a finalizer method
		962	*/
		963	int CVmObjTads::has_finalizer(VMG_ vm_obj_id_t self)
		964	{
		965	vm_val_t val;
		966	vm_obj_id_t srcobj;
		967
		968	/*
		969	* look up the finalization method - if it's defined, and it's a
		970	* method, invoke it; otherwise do nothing
		971	*/
		972	return (G_predef->obj_destruct != VM_INVALID_PROP
		973	&& get_prop(vmg_ G_predef->obj_destruct, &val, self, &srcobj, 0)
		974	&& (val.typ == VM_CODEOFS \|\| val.typ == VM_NATIVE_CODE));
		975	}
		976
		977	/* ------------------------------------------------------------------------ */
		978	/*
		979	* Invoke the object's finalizer
		980	*/
		981	void CVmObjTads::invoke_finalizer(VMG_ vm_obj_id_t self)
		982	{
		983	vm_val_t val;
		984	vm_obj_id_t srcobj;
		985
		986	/*
		987	* look up the finalization method - if it's defined, and it's a
		988	* method, invoke it; otherwise do nothing
		989	*/
		990	if (G_predef->obj_destruct != VM_INVALID_PROP
		991	&& get_prop(vmg_ G_predef->obj_destruct, &val, self, &srcobj, 0)
		992	&& (val.typ == VM_CODEOFS \|\| val.typ == VM_NATIVE_CODE))
		993	{
		994	/*
		995	* invoke the finalizer in a protected frame, to ensure that we
		996	* catch any exceptions that are thrown out of the finalizer
		997	*/
		998	err_try
		999	{
		1000	vm_val_t srcobj_val;
		1001	vm_val_t self_val;
		1002
		1003	/*
		1004	* Invoke the finalizer. Use a recursive VM invocation,
		1005	* since the VM must return to the garbage collector, not to
		1006	* what it was doing in the enclosing stack frame.
		1007	*/
		1008	srcobj_val.set_obj(srcobj);
		1009	self_val.set_obj(self);
		1010	G_interpreter->get_prop(vmg_ 0, &srcobj_val,
		1011	G_predef->obj_destruct, &self_val, 0);
		1012	}
		1013	err_catch(exc)
		1014	{
		1015	/* silently ignore the error */
		1016	}
		1017	err_end;
		1018	}
		1019	}
		1020
		1021
		1022	/* ------------------------------------------------------------------------ */
		1023	/*
		1024	* Clear the undo flags for all properties
		1025	*/
		1026	void CVmObjTads::clear_undo_flags()
		1027	{
		1028	vm_tadsobj_prop *entry;
		1029	uint i;
		1030	vm_tadsobj_hdr *hdr = get_hdr();
		1031
		1032	/* scan all property entries and clear their undo flags */
		1033	for (i = hdr->prop_entry_free, entry = hdr->prop_entry_arr ;
		1034	i != 0 ; --i, ++entry)
		1035	{
		1036	/* clear this entry's undo flag */
		1037	entry->flags &= ~VMTO_PROP_UNDO;
		1038	}
		1039	}
		1040
		1041	/* ------------------------------------------------------------------------ */
		1042	/*
		1043	* Set a property
		1044	*/
		1045	void CVmObjTads::set_prop(VMG_ CVmUndo *undo, vm_obj_id_t self,
		1046	vm_prop_id_t prop, const vm_val_t *val)
		1047	{
		1048	vm_tadsobj_prop *entry;
		1049	vm_val_t oldval;
		1050	vm_tadsobj_hdr *hdr = get_hdr();
		1051
		1052	/* look for an existing property entry */
		1053	entry = hdr->find_prop_entry(prop);
		1054
		1055	/* check for an existing entry for the property */
		1056	if (entry != 0)
		1057	{
		1058	/* found an existing entry - note the old value */
		1059	oldval = entry->val;
		1060
		1061	/* store the new value in the existing entry */
		1062	entry->val = *val;
		1063	}
		1064	else
		1065	{
		1066	/*
		1067	* We didn't find an existing entry for the property, so we have to
		1068	* add a new one. If we don't have any free property slots left,
		1069	* expand the object to create some more property slots.
		1070	*/
		1071	if (!hdr->has_free_entries(1))
		1072	{
		1073	/* expand the extension to make room for more properties */
		1074	ext_ = (char *)vm_tadsobj_hdr::expand(vmg_ this, hdr);
		1075
		1076	/* get the reallocated header */
		1077	hdr = get_hdr();
		1078	}
		1079
		1080	/* allocate a new entry */
		1081	entry = hdr->alloc_prop_entry(prop, val, 0);
		1082
		1083	/* the old value didn't exist, so mark it emtpy */
		1084	oldval.set_empty();
		1085	}
		1086
		1087	/*
		1088	* If we already have undo for this property for the current
		1089	* savepoint, as indicated by the undo flag for the property, we don't
		1090	* need to save undo for this change, since we already have an undo
		1091	* record in the current savepoint. Otherwise, we need to add an undo
		1092	* record for this savepoint.
		1093	*/
		1094	if (undo != 0 && (entry->flags & VMTO_PROP_UNDO) == 0)
		1095	{
		1096	/* save the undo record */
		1097	undo->add_new_record_prop_key(vmg_ self, prop, &oldval);
		1098
		1099	/* mark the property as now having undo in this savepoint */
		1100	entry->flags \|= VMTO_PROP_UNDO;
		1101
		1102	/*
		1103	* If the entry wasn't previously marked as modified, remember this
		1104	* by storing an extra 'empty' undo record after the record we just
		1105	* saved. We undo in reverse order, so the extra empty record
		1106	* won't actually have any effect on the property value - we'll
		1107	* immediately overwrite it with the actual value we just stored
		1108	* above. However, whenever we see an empty record, we remove the
		1109	* 'modified' flag from the property, so this will have the effect
		1110	* of undoing the modified flag. Note that we don't need to bother
		1111	* if the record we just stored was itself empty.
		1112	*/
		1113	if ((entry->flags & VMTO_PROP_MOD) == 0 && oldval.typ != VM_EMPTY)
		1114	{
		1115	/* store an empty record to undo the 'modify' flag */
		1116	oldval.set_empty();
		1117	undo->add_new_record_prop_key(vmg_ self, prop, &oldval);
		1118	}
		1119	}
		1120
		1121	/* mark the property entry as modified */
		1122	entry->flags \|= VMTO_PROP_MOD;
		1123
		1124	/* mark the entire object as modified */
		1125	hdr->intern_obj_flags \|= VMTO_OBJ_MOD;
		1126	}
		1127
		1128	/* ------------------------------------------------------------------------ */
		1129	/*
		1130	* Build a list of my properties
		1131	*/
		1132	void CVmObjTads::build_prop_list(VMG_ vm_obj_id_t self, vm_val_t *retval)
		1133	{
		1134	size_t cnt;
		1135	size_t idx;
		1136	CVmObjList *lst;
		1137	vm_tadsobj_prop *entry;
		1138	vm_tadsobj_hdr *hdr = get_hdr();
		1139
		1140	/* the next free index is also the number of properties we have */
		1141	cnt = hdr->prop_entry_free;
		1142
		1143	/* allocate a list big enough for all of our properties */
		1144	retval->set_obj(CVmObjList::create(vmg_ FALSE, cnt));
		1145
		1146	/* get the list object, property cast */
		1147	lst = (CVmObjList *)vm_objp(vmg_ retval->val.obj);
		1148
		1149	/* add our image file properties to the list */
		1150	for (idx = 0, entry = hdr->prop_entry_arr ; cnt != 0 ;
		1151	--cnt, ++entry)
		1152	{
		1153	/* if this entry isn't empty, store it */
		1154	if (entry->val.typ != VM_EMPTY)
		1155	{
		1156	vm_val_t val;
		1157
		1158	/* make a value for this property ID */
		1159	val.set_propid(entry->prop);
		1160
		1161	/* add it to the list */
		1162	lst->cons_set_element(idx++, &val);
		1163	}
		1164	}
		1165
		1166	/*
		1167	* set the final length, which might differ from the allocated length:
		1168	* we might have had some slots that were empty and thus didn't
		1169	* contribute to the list
		1170	*/
		1171	lst->cons_set_len(idx);
		1172	}
		1173
		1174
		1175	/* ------------------------------------------------------------------------ */
		1176	/*
		1177	* Call a static method.
		1178	*/
		1179	int CVmObjTads::call_stat_prop(VMG_ vm_val_t *result,
		1180	const uchar *pc_ptr, uint argc,
		1181	vm_prop_id_t prop)
		1182	{
		1183	int idx;
		1184
		1185	/* convert the property to an index in our method vector */
		1186	idx = G_meta_table
		1187	->prop_to_vector_idx(metaclass_reg_->get_reg_idx(), prop);
		1188
		1189	/* check what property they're evaluating */
		1190	switch(idx)
		1191	{
		1192	case PROPIDX_CREATE_INSTANCE:
		1193	case PROPIDX_CREATE_TRANS_INSTANCE:
		1194	{
		1195	static CVmNativeCodeDesc desc(0);
		1196
		1197	/* check arguments */
		1198	if (get_prop_check_argc(result, argc, &desc))
		1199	return TRUE;
		1200
		1201	/*
		1202	* They want to create an instance of TadsObject, which is
		1203	* just a plain base object with no superclass. Push null as
		1204	* the base class and call our from-stack constructor.
		1205	*/
		1206	result->set_obj(create_from_stack_intern(
		1207	vmg_ pc_ptr, 0, idx == PROPIDX_CREATE_TRANS_INSTANCE));
		1208	}
		1209
		1210	/* handled */
		1211	return TRUE;
		1212
		1213	case PROPIDX_CREATE_INSTANCE_OF:
		1214	case PROPIDX_CREATE_TRANS_INSTANCE_OF:
		1215	{
		1216	static CVmNativeCodeDesc desc(0, 0, TRUE);
		1217	uint in_argc = (argc == 0 ? 0 : *argc);
		1218
		1219	/* check arguments */
		1220	if (get_prop_check_argc(result, argc, &desc))
		1221	return TRUE;
		1222
		1223	/*
		1224	* They want to create an instance of TadsObject, which is just
		1225	* a plain base object with no superclass. Push null as the
		1226	* base class and call our from-stack constructor.
		1227	*/
		1228	result->set_obj(create_from_stack_multi(
		1229	vmg_ in_argc, idx == PROPIDX_CREATE_TRANS_INSTANCE_OF));
		1230	}
		1231
		1232	/* handled */
		1233	return TRUE;
		1234
		1235	default:
		1236	/* it's not one of ours; inherit the base class statics */
		1237	return CVmObject::call_stat_prop(vmg_ result, pc_ptr, argc, prop);
		1238	}
		1239	}
		1240
		1241	/* ------------------------------------------------------------------------ */
		1242	/*
		1243	* Superclass inheritance search context. This keeps track of our position
		1244	* in searching the inheritance tree of a given class.
		1245	*/
		1246	struct tadsobj_sc_search_ctx
		1247	{
		1248	/* initialize at a given object */
		1249	tadsobj_sc_search_ctx(VMG_ vm_obj_id_t obj, CVmObjTads *objp)
		1250	{
		1251	/* start at the given object */
		1252	cur = obj;
		1253	curp = objp;
		1254
		1255	/* we have no path yet */
		1256	path_rem = -1;
		1257	}
		1258
		1259	/* current object ID and pointer */
		1260	vm_obj_id_t cur;
		1261	CVmObjTads *curp;
		1262
		1263	/*
		1264	* If we have a search path, the position in the path and the number of
		1265	* elements remaining. We use the special remaining path length of -1
		1266	* to indicate that we're not looking at a path at all; this is useful
		1267	* because it allows us to perform a single test to determine if we're
		1268	* operating on a path with elements remaining, operating on an empty
		1269	* path, or working without a path at all. (This code gets hit *a
		1270	* lot*, so we want it as fast as possible.)
		1271	*/
		1272	tadsobj_objid_and_ptr *path_sc;
		1273	int path_rem;
		1274
		1275	/*
		1276	* Find the given property, searching our superclass list until we find
		1277	* an object providing the property. Returns true if found, and fills
		1278	* in val and source. Returns false if not found.
		1279	*/
		1280	int find_prop(VMG_ uint prop, vm_val_t val, vm_obj_id_t source)
		1281	{
		1282	/* keep going until we find the property */
		1283	for (;;)
		1284	{
		1285	vm_tadsobj_prop *entry;
		1286
		1287	/* look for this property in the current object */
		1288	entry = curp->get_hdr()->find_prop_entry(prop);
		1289
		1290	/* if we found a non-empty entry, return the value */
		1291	if (entry != 0 && entry->val.typ != VM_EMPTY)
		1292	{
		1293	/* we found the property - return it */
		1294	*val = entry->val;
		1295	*source = cur;
		1296	return TRUE;
		1297	}
		1298
		1299	/* didn't find it - move to the next search position */
		1300	if (!to_next(vmg0_))
		1301	{
		1302	/* there's nowhere else to search - we've failed to find it */
		1303	return FALSE;
		1304	}
		1305	}
		1306	}
		1307
		1308	/*
		1309	* Skip to the given object. If we find the object in the path, we'll
		1310	* leave the current position set to the given object and return true;
		1311	* if we fail to find the object, we'll return false.
		1312	*/
		1313	int skip_to(VMG_ vm_obj_id_t target)
		1314	{
		1315	/* keep going until the current object matches the target */
		1316	while (cur != target)
		1317	{
		1318	/* move to the next element */
		1319	if (!to_next(vmg0_))
		1320	{
		1321	/* there's nothing left - return failure */
		1322	return FALSE;
		1323	}
		1324	}
		1325
		1326	/* found it */
		1327	return TRUE;
		1328	}
		1329
		1330	/*
		1331	* Move to the next superclass. This updates 'cur' to refer to the
		1332	* next object in inheritance order. Returns true if there is a next
		1333	* element, false if not.
		1334	*
		1335	* It is legal to call this with 'cur' set to an arbitrary object, as
		1336	* we do not need the old value of 'cur' to do our work. (This is
		1337	* important because it allows a search position to be initialized
		1338	* knowing only an object's 'this' pointer, not its object ID.)
		1339	*/
		1340	int to_next(VMG0_)
		1341	{
		1342	tadsobj_inh_path *path;
		1343	vm_tadsobj_hdr *hdr;
		1344
		1345	/*
		1346	* If we have a path, continue with it. Note that the special
		1347	* value -1 for the remaining length indicates that we're not
		1348	* working on a path at all.
		1349	*/
		1350	switch(path_rem)
		1351	{
		1352	case 0:
		1353	/*
		1354	* we're working on a path, and we're out of elements - we have
		1355	* nowhere else to go
		1356	*/
		1357	return FALSE;
		1358
		1359	default:
		1360	/*
		1361	* we're working on a path, and we have elements remaining -
		1362	* move on to the next element
		1363	*/
		1364	cur = path_sc->id;
		1365	curp = path_sc->objp;
		1366	++path_sc;
		1367	--path_rem;
		1368
		1369	/* got it */
		1370	return TRUE;
		1371
		1372	case -1:
		1373	/*
		1374	* we're not working on a path at all - this means we're
		1375	* working directly on a (so far) single-inheritance superclass
		1376	* chain, so simply follow the chain up to the next superclass
		1377	*/
		1378
		1379	/* get this object's header */
		1380	hdr = curp->get_hdr();
		1381
		1382	/* we have no path, so look at our object's superclasses */
		1383	switch(hdr->sc_cnt)
		1384	{
		1385	case 1:
		1386	/* we have exactly one superclass, so traverse to it */
		1387	cur = hdr->sc[0].id;
		1388	if ((curp = hdr->sc[0].objp) == 0)
		1389	curp = hdr->sc[0].objp = (CVmObjTads *)vm_objp(vmg_ cur);
		1390	return TRUE;
		1391
		1392	case 0:
		1393	/* we have no superclasses, so there's nowhere to go */
		1394	return FALSE;
		1395
		1396	default:
		1397	/* we have multiple superclasses, so set up the search path */
		1398	if ((path = hdr->inh_path) == 0
		1399	&& (path = curp->get_inh_search_path(vmg0_)) == 0)
		1400	{
		1401	/* there's no path, so there's nowhere to go */
		1402	return FALSE;
		1403	}
		1404
		1405	/* move to the first element of the path */
		1406	path_rem = path->cnt - 1;
		1407	path_sc = path->sc;
		1408	cur = path_sc->id;
		1409	curp = path_sc->objp;
		1410	++path_sc;
		1411	return TRUE;
		1412	}
		1413	}
		1414	}
		1415	};
		1416
		1417	/*
		1418	* Search for a property via inheritance, starting after the given defining
		1419	* object.
		1420	*/
		1421	int CVmObjTads::search_for_prop_from(VMG_ uint prop,
		1422	vm_val_t *val,
		1423	vm_obj_id_t orig_target_obj,
		1424	vm_obj_id_t *source_obj,
		1425	vm_obj_id_t defining_obj)
		1426	{
		1427	/* set up a search position */
		1428	tadsobj_sc_search_ctx curpos(vmg_ orig_target_obj,
		1429	(CVmObjTads *)vm_objp(vmg_ orig_target_obj));
		1430
		1431	/* if we have a starting point, skip past it */
		1432	if (defining_obj != VM_INVALID_OBJ)
		1433	{
		1434	/* skip until we're at defining_obj */
		1435	if (!curpos.skip_to(vmg_ defining_obj))
		1436	return FALSE;
		1437
		1438	/* skip defining_obj itself */
		1439	if (!curpos.to_next(vmg0_))
		1440	return FALSE;
		1441	}
		1442
		1443	/* find the property */
		1444	return curpos.find_prop(vmg_ prop, val, source_obj);
		1445	}
		1446
		1447	/* ------------------------------------------------------------------------ */
		1448	/*
		1449	* Get a property. We first look in this object; if we can't find the
		1450	* property here, we look for it in one of our superclasses.
		1451	*/
		1452	int CVmObjTads::get_prop(VMG_ vm_prop_id_t prop, vm_val_t *val,
		1453	vm_obj_id_t self, vm_obj_id_t *source_obj,
		1454	uint *argc)
		1455	{
		1456	/*
		1457	* Try finding the property in our property list or a superclass
		1458	* property list. Since we're starting a new search, 'self' is the
		1459	* original target object, and we do not have a previous defining
		1460	* object.
		1461	*/
		1462	tadsobj_sc_search_ctx curpos(vmg_ self, this);
		1463	if (curpos.find_prop(vmg_ prop, val, source_obj))
		1464	return TRUE;
		1465
		1466	/*
		1467	* we didn't find the property in a property list, so try the
		1468	* intrinsic class methods
		1469	*/
		1470	if (get_prop_intrinsic(vmg_ prop, val, self, source_obj, argc))
		1471	return TRUE;
		1472
		1473	/*
		1474	* we didn't find the property among our methods, so try inheriting it
		1475	* from the base metaclass
		1476	*/
		1477	return CVmObject::get_prop(vmg_ prop, val, self, source_obj, argc);
		1478	}
		1479
		1480	/*
		1481	* Inherit a property.
		1482	*/
		1483	int CVmObjTads::inh_prop(VMG_ vm_prop_id_t prop, vm_val_t *val,
		1484	vm_obj_id_t self,
		1485	vm_obj_id_t orig_target_obj,
		1486	vm_obj_id_t defining_obj,
		1487	vm_obj_id_t source_obj, uint argc)
		1488	{
		1489	/*
		1490	* check to see if we're already inheriting from an intrinsic class or
		1491	* an intrinsic class modifier
		1492	*/
		1493	if (defining_obj == VM_INVALID_OBJ
		1494	\|\| (!CVmObjIntClsMod::is_intcls_mod_obj(vmg_ defining_obj)
		1495	&& !CVmObjClass::is_intcls_obj(vmg_ defining_obj)))
		1496	{
		1497	/*
		1498	* The previous defining object wasn't itself an intrinsic class or
		1499	* modifier object, so continue searching for TadsObject
		1500	* superclasses.
		1501	*/
		1502	if (search_for_prop_from(vmg_ prop, val,
		1503	orig_target_obj, source_obj, defining_obj))
		1504	return TRUE;
		1505
		1506	/*
		1507	* We didn't find the property in a property list. Since we were
		1508	* inheriting, we must have originally found it in a property list,
		1509	* but we've found no more inherited properties. Next, check the
		1510	* intrinsic methods of the intrinsic class.
		1511	*/
		1512	if (get_prop_intrinsic(vmg_ prop, val, self, source_obj, argc))
		1513	return TRUE;
		1514
		1515	/*
		1516	* We didn't find it among our TadsObject superclasses or as an
		1517	* intrinsic method. There's still one possibility: it could be
		1518	* defined in an intrinsic class modifier for TadsObject or one of
		1519	* its intrinsic superclasses (aka supermetaclasses).
		1520	*
		1521	* This represents a new starting point in the search. No longer
		1522	* are we looking for TadsObject overrides; we're now looking for
		1523	* modifier objects. The modifier objects effectively form a
		1524	* separate class hierarchy alongside the intrinsic class hierarchy
		1525	* they modify. Since we're starting a new search in this new
		1526	* context, forget the previous defining object - it has a
		1527	* different meaning in the new context, and we want to start the
		1528	* new search from the beginning.
		1529	*
		1530	* Note that if this search does turn up a modifier object, and
		1531	* that modifier object further inherits, we'll come back through
		1532	* this method again to find the base class method. At that point,
		1533	* however we'll notice that the previous defining object was a
		1534	* modifier, so we will not go through this branch again - we'll go
		1535	* directly to the base metaclass and continue the inheritance
		1536	* search there.
		1537	*/
		1538	defining_obj = VM_INVALID_OBJ;
		1539	}
		1540
		1541	/* continue searching via our base metaclass */
		1542	return CVmObject::inh_prop(vmg_ prop, val, self, orig_target_obj,
		1543	defining_obj, source_obj, argc);
		1544	}
		1545
		1546	/* ------------------------------------------------------------------------ */
		1547	/*
		1548	* Get a property from the intrinsic class.
		1549	*/
		1550	int CVmObjTads::get_prop_intrinsic(VMG_ vm_prop_id_t prop, vm_val_t *val,
		1551	vm_obj_id_t self, vm_obj_id_t *source_obj,
		1552	uint *argc)
		1553	{
		1554	uint func_idx;
		1555
		1556	/* translate the property into a function vector index */
		1557	func_idx = G_meta_table
		1558	->prop_to_vector_idx(metaclass_reg_->get_reg_idx(), prop);
		1559
		1560	/* call the appropriate function in our function vector */
		1561	if ((this->*func_table_[func_idx])(vmg_ self, val, argc))
		1562	{
		1563	*source_obj = metaclass_reg_->get_class_obj(vmg0_);
		1564	return TRUE;
		1565	}
		1566
		1567	/* didn't find it */
		1568	return FALSE;
		1569	}
		1570
		1571	/* ------------------------------------------------------------------------ */
		1572	/*
		1573	* Get the inheritance search path for this object
		1574	*/
		1575	tadsobj_inh_path *CVmObjTads::get_inh_search_path(VMG0_)
		1576	{
		1577	CVmObjTads *curp;
		1578	CVmObjTadsInhQueue *q = G_tadsobj_queue;
		1579	pfq_ele *q_ele;
		1580	vm_tadsobj_hdr *hdr = get_hdr();
		1581	tadsobj_inh_path *path;
		1582
		1583	/*
		1584	* There are multiple superclasses. If we've already calculated a
		1585	* path for this object, simply use the pre-calculated path: the
		1586	* superclass relationships among objects never change, so the path is
		1587	* good forever.
		1588	*/
		1589	if (hdr->inh_path != 0)
		1590	return hdr->inh_path;
		1591
		1592	/*
		1593	* We haven't already cached a search path for this object, so build
		1594	* the search path now and save it for future searches. Start by
		1595	* clearing the work queue.
		1596	*/
		1597	q->clear();
		1598
		1599	/* we're not yet processing the first element */
		1600	q_ele = 0;
		1601
		1602	/* start with self */
		1603	curp = this;
		1604
		1605	/* keep going until we run out of queue elements */
		1606	for (;;)
		1607	{
		1608	ushort i;
		1609	ushort cnt;
		1610	pfq_ele *q_ins;
		1611	vm_tadsobj_sc *scp;
		1612	vm_tadsobj_hdr *curhdr;
		1613
		1614	/* get the superclass count for this object */
		1615	curhdr = curp->get_hdr();
		1616	cnt = curhdr->sc_cnt;
		1617
		1618	/* insert my superclasses right after me */
		1619	q_ins = q_ele;
		1620
		1621	/* enqueue the current object's superclasses */
		1622	for (i = 0, scp = curhdr->sc ; i < cnt ; ++i, ++scp)
		1623	{
		1624	vm_obj_id_t sc;
		1625	CVmObjTads *scobj;
		1626
		1627	/* get the current superclass */
		1628	sc = scp->id;
		1629	if ((scobj = scp->objp) == 0)
		1630	scobj = scp->objp = (CVmObjTads *)vm_objp(vmg_ sc);
		1631
		1632	/* if it's not a TadsObject, skip it */
		1633	if (scobj->get_metaclass_reg() != curp->get_metaclass_reg())
		1634	continue;
		1635
		1636	/* enqueue this superclass */
		1637	q_ins = q->insert_obj(vmg_ sc, scobj, q_ins);
		1638	}
		1639
		1640	/* move to the next valid element */
		1641	for (;;)
		1642	{
		1643	/* get the next queue element */
		1644	q_ele = (q_ele == 0 ? q->get_head() : q_ele->nxt);
		1645
		1646	/*
		1647	* if it's valid, or we're out of elements, stop searching for
		1648	* it
		1649	*/
		1650	if (q_ele == 0 \|\| q_ele->obj != VM_INVALID_OBJ)
		1651	break;
		1652	}
		1653
		1654	/* if we ran out of elements, we're done */
		1655	if (q_ele == 0)
		1656	break;
		1657
		1658	/* get this item */
		1659	curp = q_ele->objp;
		1660	}
		1661
		1662	/*
		1663	* if the linearized path is empty, there's nowhere to go from here,
		1664	* so we've failed to find the property
		1665	*/
		1666	if (q->is_empty())
		1667	return 0;
		1668
		1669	/* create and cache a linearized path for the queue, and return it */
		1670	path = hdr->inh_path = q->create_path();
		1671	return path;
		1672	}
		1673
		1674	/* ------------------------------------------------------------------------ */
		1675	/*
		1676	* Enumerate properties
		1677	*/
		1678	void CVmObjTads::enum_props(VMG_ vm_obj_id_t self,
		1679	void (cb)(VMG_ void ctx, vm_obj_id_t self,
		1680	vm_prop_id_t prop,
		1681	const vm_val_t *val),
		1682	void *cbctx)
		1683	{
		1684	size_t i;
		1685	size_t sc_cnt;
		1686	vm_tadsobj_prop *entry;
		1687	vm_tadsobj_hdr *hdr = get_hdr();
		1688
		1689	/* run through our non-empty properties */
		1690	for (i = hdr->prop_entry_free, entry = hdr->prop_entry_arr ;
		1691	i != 0 ; --i, ++entry)
		1692	{
		1693	/* if this one is non-empty, invoke the callback */
		1694	if (entry->val.typ != VM_EMPTY)
		1695	(*cb)(vmg_ cbctx, self, entry->prop, &entry->val);
		1696	}
		1697
		1698	/* enumerate properties in each superclass */
		1699	sc_cnt = get_sc_count();
		1700	for (i = 0 ; i < sc_cnt ; ++i)
		1701	{
		1702	vm_obj_id_t sc;
		1703
		1704	/* get this superclass */
		1705	sc = get_sc(i);
		1706
		1707	/* enumerate its properties */
		1708	vm_objp(vmg_ sc)->enum_props(vmg_ sc, cb, cbctx);
		1709	}
		1710	}
		1711
		1712
		1713	/* ------------------------------------------------------------------------ */
		1714	/*
		1715	* Determine if I'm an instance of the given object
		1716	*/
		1717	int CVmObjTads::is_instance_of(VMG_ vm_obj_id_t obj)
		1718	{
		1719	/*
		1720	* Set up a superclass search position. Since the first thing we'll
		1721	* do is call 'to_next', and since 'to_next' doesn't require a valid
		1722	* current object ID (only a valid 'this' pointer), we don't need to
		1723	* know our own object ID - simply set the initial object ID to the
		1724	* invalid ID.
		1725	*/
		1726	tadsobj_sc_search_ctx curpos(vmg_ VM_INVALID_OBJ, this);
		1727
		1728	/*
		1729	* scan through the search list, comparing each superclass to the
		1730	* object of interest; if we find it among our superclasses, we're an
		1731	* instance of the given object
		1732	*/
		1733	for (;;)
		1734	{
		1735	/* skip to the next object */
		1736	if (!curpos.to_next(vmg0_))
		1737	{
		1738	/* we've run out of superclasses without finding it */
		1739	break;
		1740	}
		1741
		1742	/*
		1743	* if the current superclass is the object we're looking for, then
		1744	* we're an instance of that object
		1745	*/
		1746	if (curpos.cur == obj)
		1747	return TRUE;
		1748	}
		1749
		1750	/*
		1751	* None of our superclasses match the given object, and none of the
		1752	* superclasses derive from the given object, so we must not derive
		1753	* from the given object. Our last recourse is to determine if the
		1754	* object represents our metaclass; inherit the default handling to
		1755	* make this check.
		1756	*/
		1757	return CVmObject::is_instance_of(vmg_ obj);
		1758	}
		1759
		1760	/* ------------------------------------------------------------------------ */
		1761	/*
		1762	* Apply undo
		1763	*/
		1764	void CVmObjTads::apply_undo(VMG_ CVmUndoRecord *rec)
		1765	{
		1766	vm_tadsobj_prop *entry;
		1767	vm_tadsobj_hdr *hdr = get_hdr();
		1768
		1769	/*
		1770	* if the property is 'invalid', this is an undo record for a
		1771	* superclass list change rather than a property change
		1772	*/
		1773	if (rec->id.prop == VM_INVALID_PROP)
		1774	{
		1775	const char *lstp;
		1776
		1777	/* get the old list */
		1778	lstp = rec->oldval.get_as_list(vmg0_);
		1779
		1780	/* set the new superclass list */
		1781	change_superclass_list(vmg_ lstp, (ushort)vmb_get_len(lstp));
		1782
		1783	/* we're done with this undo record */
		1784	return;
		1785	}
		1786
		1787	/* find the property entry for the property being undone */
		1788	entry = hdr->find_prop_entry(rec->id.prop);
		1789	if (entry == 0)
		1790	{
		1791	/* can't find the property - something is out of whack */
		1792	assert(FALSE);
		1793	return;
		1794	}
		1795
		1796	/*
		1797	* Restore the value from the record. Note that if the property
		1798	* didn't previously exist, this will store 'empty' in the slot; we
		1799	* don't actually delete the slot, but the 'empty' marker is
		1800	* equivalent, in that we treat it as a property we don't define.
		1801	*/
		1802	entry->val = rec->oldval;
		1803
		1804	/*
		1805	* If the old value was 'empty', mark the slot as unmodified. Since
		1806	* the property didn't exist previously, it can't have been modified
		1807	* previously. Note that we add an artifical extra 'empty' record the
		1808	* first time an existing load image property is modified, so that this
		1809	* un-setting of the 'modified' flag will happen even for properties
		1810	* that existed before the first modification.
		1811	*/
		1812	if (rec->oldval.typ == VM_EMPTY)
		1813	{
		1814	size_t i;
		1815	int found_mod;
		1816
		1817	/* clear the 'modified' flag on the property */
		1818	entry->flags &= ~VMTO_PROP_MOD;
		1819
		1820	/*
		1821	* scan the properties to see if we still need the 'modified' flag
		1822	* on the object itself - this might have been the only remaining
		1823	* modified property, in which case we no longer have any modified
		1824	* properties and thus no longer have a modified object
		1825	*/
		1826	for (found_mod = FALSE, i = hdr->prop_entry_free,
		1827	entry = hdr->prop_entry_arr ; i != 0 ; --i, ++entry)
		1828	{
		1829	/*
		1830	* if this is property is marked as modified, we still have a
		1831	* modified object
		1832	*/
		1833	if ((entry->flags & VMTO_PROP_MOD) != 0)
		1834	{
		1835	/* note that we found a modified property */
		1836	found_mod = TRUE;
		1837
		1838	/* no need to look any further */
		1839	break;
		1840	}
		1841	}
		1842
		1843	/*
		1844	* if we found no modified properties, the object is no longer
		1845	* modified, so clear its 'modified' flag
		1846	*/
		1847	if (!found_mod)
		1848	hdr->intern_obj_flags &= ~VMTO_OBJ_MOD;
		1849	}
		1850	}
		1851
		1852
		1853	/* ------------------------------------------------------------------------ */
		1854	/*
		1855	* Mark as referenced all of the objects to which we refer
		1856	*/
		1857	void CVmObjTads::mark_refs(VMG_ uint state)
		1858	{
		1859	size_t i;
		1860	vm_tadsobj_hdr *hdr = get_hdr();
		1861	vm_tadsobj_prop *entry;
		1862	vm_tadsobj_sc *scp;
		1863
		1864	/*
		1865	* Go through all of our property slots and mark each object value.
		1866	* Note that we only need to worry about the modified properties;
		1867	* everything referenced in the load image list is necessarily part of
		1868	* the root set, or it couldn't have been in the load image, so we
		1869	* don't need to bother marking any of those objects, since they can
		1870	* never be deleted by virtue of being in the root set.
		1871	*/
		1872	for (i = hdr->prop_entry_free, entry = hdr->prop_entry_arr ;
		1873	i != 0 ; --i, ++entry)
		1874	{
		1875	/*
		1876	* if the slot is marked as modified and contains an object
		1877	* reference, mark the reference
		1878	*/
		1879	if ((entry->flags & VMTO_PROP_MOD) != 0
		1880	&& entry->val.typ == VM_OBJ
		1881	&& entry->val.val.obj != VM_INVALID_OBJ)
		1882	{
		1883	/* mark the reference */
		1884	G_obj_table->mark_all_refs(entry->val.val.obj, state);
		1885	}
		1886	}
		1887
		1888	/* mark our superclasses as referenced */
		1889	for (i = hdr->sc_cnt, scp = hdr->sc ; i != 0 ; --i, ++scp)
		1890	G_obj_table->mark_all_refs(scp->id, state);
		1891	}
		1892
		1893
		1894	/* ------------------------------------------------------------------------ */
		1895	/*
		1896	* Mark a reference in an undo record
		1897	*/
		1898	void CVmObjTads::mark_undo_ref(VMG_ CVmUndoRecord *undo)
		1899	{
		1900	/* if the undo record refers to an object, mark the object */
		1901	if (undo->oldval.typ == VM_OBJ)
		1902	G_obj_table->mark_all_refs(undo->oldval.val.obj, VMOBJ_REACHABLE);
		1903	}
		1904
		1905	/* ------------------------------------------------------------------------ */
		1906	/*
		1907	* Determine if the object has been changed since it was loaded from the
		1908	* image file. If the object has no properties stored in the modified
		1909	* properties table, it is in exactly the same state as is stored in the
		1910	* image file.
		1911	*/
		1912	int CVmObjTads::is_changed_since_load() const
		1913	{
		1914	/* return our 'modified' flag */
		1915	return ((get_hdr()->intern_obj_flags & VMTO_OBJ_MOD) != 0);
		1916	}
		1917
		1918	/* ------------------------------------------------------------------------ */
		1919	/*
		1920	* Save the object's state to a file. We only need to save the modified
		1921	* property list, because the load image list never changes.
		1922	*/
		1923	void CVmObjTads::save_to_file(VMG_ CVmFile *fp)
		1924	{
		1925	size_t i;
		1926	vm_tadsobj_prop *entry;
		1927	uint cnt;
		1928	vm_tadsobj_hdr *hdr = get_hdr();
		1929
		1930	/* count the number of properties that have actually been modified */
		1931	for (cnt = 0, i = hdr->prop_entry_free, entry = hdr->prop_entry_arr ;
		1932	i != 0 ; --i, ++entry)
		1933	{
		1934	/* if the slot is non-empty and modified, count it */
		1935	if ((entry->flags & VMTO_PROP_MOD) != 0
		1936	&& entry->val.typ != VM_EMPTY)
		1937	++cnt;
		1938	}
		1939
		1940	/* write the number of modified properties */
		1941	fp->write_int2(cnt);
		1942
		1943	/* write the number of superclasses */
		1944	fp->write_int2(get_sc_count());
		1945
		1946	/* write the superclasses */
		1947	for (i = 0 ; i < get_sc_count() ; ++i)
		1948	fp->write_int4(get_sc(i));
		1949
		1950	/* write each modified property */
		1951	for (cnt = 0, i = hdr->prop_entry_free, entry = hdr->prop_entry_arr ;
		1952	i != 0 ; --i, ++entry)
		1953	{
		1954	/* if the slot is non-empty and modified, write it out */
		1955	if ((entry->flags & VMTO_PROP_MOD) != 0
		1956	&& entry->val.typ != VM_EMPTY)
		1957	{
		1958	char slot[16];
		1959
		1960	/* prepare the slot data */
		1961	oswp2(slot, entry->prop);
		1962	vmb_put_dh(slot + 2, &entry->val);
		1963
		1964	/* write the slot */
		1965	fp->write_bytes(slot, 2 + VMB_DATAHOLDER);
		1966	}
		1967	}
		1968	}
		1969
		1970	/* ------------------------------------------------------------------------ */
		1971	/*
		1972	* Restore the object from a file
		1973	*/
		1974	void CVmObjTads::restore_from_file(VMG_ vm_obj_id_t self,
		1975	CVmFile fp, CVmObjFixup fixups)
		1976	{
		1977	ushort mod_count;
		1978	ushort i;
		1979	ushort sc_cnt;
		1980	vm_tadsobj_hdr *hdr;
		1981
		1982	/* read number of modified properties */
		1983	mod_count = (ushort)fp->read_uint2();
		1984
		1985	/* read the number of superclasses */
		1986	sc_cnt = (ushort)fp->read_uint2();
		1987
		1988	/*
		1989	* If we don't have an extension yet, allocate one. The only way we
		1990	* won't have an extension is if we weren't loaded from the image
		1991	* file, since we always create the extension upon construction when
		1992	* loading from an image file.
		1993	*/
		1994	if (ext_ == 0)
		1995	{
		1996	/* allocate our extension */
		1997	ext_ = (char *)vm_tadsobj_hdr::alloc(vmg_ this, sc_cnt, mod_count);
		1998	}
		1999	else
		2000	{
		2001	/*
		2002	* We already have an extension, so we must have come from the
		2003	* image file. Make sure we have enough memory to hold this many
		2004	* properties, and make sure we have space for the superclasses.
		2005	*/
		2006	hdr = get_hdr();
		2007	if (!hdr->has_free_entries(mod_count) \|\| sc_cnt > hdr->sc_cnt)
		2008	{
		2009	/*
		2010	* we need to expand the header to accomodate the modified
		2011	* properties and/or the modified superclass list
		2012	*/
		2013	ext_ = (char *)vm_tadsobj_hdr::expand_to(
		2014	vmg_ this, hdr, sc_cnt, hdr->prop_entry_cnt + mod_count);
		2015	}
		2016	}
		2017
		2018	/* get the extension header */
		2019	hdr = get_hdr();
		2020
		2021	/* read the superclass list */
		2022	hdr->sc_cnt = sc_cnt;
		2023	for (i = 0 ; i < sc_cnt ; ++i)
		2024	{
		2025	vm_obj_id_t sc;
		2026
		2027	/* read the next superclass */
		2028	sc = (vm_obj_id_t)fp->read_uint4();
		2029
		2030	/* fix it up to the memory numbering system */
		2031	sc = fixups->get_new_id(vmg_ sc);
		2032
		2033	/*
		2034	* store it - as when loading from the image file, we can't count
		2035	* on the superclass having been loaded yet, so we can only store
		2036	* the superclass's ID, not its actual object pointer
		2037	*/
		2038	hdr->sc[i].id = sc;
		2039	hdr->sc[i].objp = 0;
		2040	}
		2041
		2042	/*
		2043	* invalidate any existing inheritance path, in case the superclass
		2044	* list changed
		2045	*/
		2046	hdr->inval_inh_path();
		2047
		2048	/* read the modified properties */
		2049	for (i = 0 ; i < mod_count ; ++i)
		2050	{
		2051	char buf[32];
		2052	vm_prop_id_t prop;
		2053	vm_val_t val;
		2054
		2055	/* read the next slot */
		2056	fp->read_bytes(buf, 2 + VMB_DATAHOLDER);
		2057
		2058	/* fix up this entry */
		2059	fixups->fix_dh(vmg_ buf + 2);
		2060
		2061	/* decode the entry */
		2062	prop = (vm_prop_id_t)osrp2(buf);
		2063	vmb_get_dh(buf + 2, &val);
		2064
		2065	/*
		2066	* store the entry (don't save any undo for the operation, as we
		2067	* can't undo a load)
		2068	*/
		2069	set_prop(vmg_ 0, self, prop, &val);
		2070	}
		2071
		2072	/* clear all undo information */
		2073	clear_undo_flags();
		2074	}
		2075
		2076	/* ------------------------------------------------------------------------ */
		2077	/*
		2078	* Load the object from an image file
		2079	*/
		2080	void CVmObjTads::load_from_image(VMG_ vm_obj_id_t self,
		2081	const char *ptr, size_t siz)
		2082	{
		2083	ushort sc_cnt;
		2084	ushort li_cnt;
		2085	vm_tadsobj_hdr *hdr;
		2086
		2087	/* save our image data pointer for reloading */
		2088	G_obj_table->save_image_pointer(self, ptr, siz);
		2089
		2090	/* if we already have memory allocated, free it */
		2091	if (ext_ != 0)
		2092	{
		2093	G_mem->get_var_heap()->free_mem(ext_);
		2094	ext_ = 0;
		2095	}
		2096
		2097	/* get the number of superclasses */
		2098	sc_cnt = osrp2(ptr);
		2099
		2100	/* get the number of load image properties */
		2101	li_cnt = osrp2(ptr + 2);
		2102
		2103	/* allocate our header */
		2104	ext_ = (char *)vm_tadsobj_hdr::alloc(vmg_ this, sc_cnt, li_cnt);
		2105	hdr = get_hdr();
		2106
		2107	/* read the object flags from the image file and store them */
		2108	hdr->li_obj_flags = osrp2(ptr + 4);
		2109
		2110	/* set our internal flags - we come from the load image file */
		2111	hdr->intern_obj_flags \|= VMTO_OBJ_IMAGE;
		2112
		2113	/* load the image file properties */
		2114	load_image_props_and_scs(vmg_ ptr, siz);
		2115	}
		2116
		2117	/*
		2118	* Reset to image file state. Discards all modified properties, so that
		2119	* we have only the image file properties.
		2120	*/
		2121	void CVmObjTads::reload_from_image(VMG_ vm_obj_id_t /self/,
		2122	const char *ptr, size_t siz)
		2123	{
		2124	vm_tadsobj_hdr *hdr = get_hdr();
		2125	ushort sc_cnt;
		2126
		2127	/* get the number of superclasses */
		2128	sc_cnt = osrp2(ptr);
		2129
		2130	/*
		2131	* Clear the property table. We don't have to worry about the new
		2132	* property table being larger than the existing property table,
		2133	* because we can't have shrunk since we were originally loaded. So,
		2134	* all we need to do is mark all property entries as free and clear
		2135	* out the hash table.
		2136	*/
		2137	hdr->prop_entry_free = 0;
		2138	memset(hdr->hash_arr, 0, hdr->hash_siz * sizeof(hdr->hash_arr[0]));
		2139
		2140	/* if we need space for more superclasses, reallocate the header */
		2141	if (sc_cnt > hdr->sc_cnt)
		2142	{
		2143	/* allocate the new header */
		2144	ext_ = (char *)vm_tadsobj_hdr::expand_to(
		2145	vmg_ this, hdr, sc_cnt, hdr->prop_entry_cnt);
		2146	}
		2147
		2148	/* reload the image properties */
		2149	load_image_props_and_scs(vmg_ ptr, siz);
		2150	}
		2151
		2152	/*
		2153	* Load the property list from the image data
		2154	*/
		2155	void CVmObjTads::load_image_props_and_scs(VMG_ const char *ptr, size_t siz)
		2156	{
		2157	vm_tadsobj_hdr *hdr = get_hdr();
		2158	ushort i;
		2159	ushort sc_cnt;
		2160	ushort li_cnt;
		2161	const char *p;
		2162
		2163	/* get the number of superclasses */
		2164	sc_cnt = osrp2(ptr);
		2165
		2166	/* get the number of load image properties */
		2167	li_cnt = osrp2(ptr + 2);
		2168
		2169	/* read the superclasses from the load image and store them */
		2170	for (i = 0, p = ptr + 6 ; i < sc_cnt ; ++i, p += 4)
		2171	{
		2172	/* store the object ID */
		2173	hdr->sc[i].id = (vm_obj_id_t)t3rp4u(p);
		2174
		2175	/*
		2176	* we can't store the superclass pointer yet, as the superclass
		2177	* object might not be loaded yet
		2178	*/
		2179	hdr->sc[i].objp = 0;
		2180	}
		2181
		2182	/* read the properties from the load image and store them */
		2183	for (i = 0 ; i < li_cnt ; ++i, p += 2 + VMB_DATAHOLDER)
		2184	{
		2185	vm_prop_id_t prop;
		2186	vm_val_t val;
		2187
		2188	/* decode the property data */
		2189	prop = (vm_prop_id_t)osrp2(p);
		2190	vmb_get_dh(p + 2, &val);
		2191
		2192	/* store the property */
		2193	hdr->alloc_prop_entry(prop, &val, 0);
		2194	}
		2195	}
		2196
		2197	/* ------------------------------------------------------------------------ */
		2198	/*
		2199	* Property evaluator - createInstance
		2200	*/
		2201	int CVmObjTads::getp_create_instance(VMG_ vm_obj_id_t self,
		2202	vm_val_t retval, uint in_argc)
		2203	{
		2204	/* create a persistent instance */
		2205	return getp_create_common(vmg_ self, retval, in_argc, FALSE);
		2206	}
		2207
		2208	/*
		2209	* Property evaluator - createTransientInstance
		2210	*/
		2211	int CVmObjTads::getp_create_trans_instance(VMG_ vm_obj_id_t self,
		2212	vm_val_t retval, uint in_argc)
		2213	{
		2214	/* create a transient instance */
		2215	return getp_create_common(vmg_ self, retval, in_argc, TRUE);
		2216	}
		2217
		2218	/*
		2219	* Common handler for createInstance() and createTransientInstance()
		2220	*/
		2221	int CVmObjTads::getp_create_common(VMG_ vm_obj_id_t self,
		2222	vm_val_t retval, uint in_argc,
		2223	int is_transient)
		2224	{
		2225	uint argc = (in_argc != 0 ? *in_argc : 0);
		2226	static CVmNativeCodeDesc desc(0, 0, TRUE);
		2227
		2228	/* check arguments - any number are allowed */
		2229	if (get_prop_check_argc(retval, in_argc, &desc))
		2230	return TRUE;
		2231
		2232	/*
		2233	* push myself as the first argument - 'self' is the superclass of the
		2234	* object to be created
		2235	*/
		2236	G_interpreter->push_obj(vmg_ self);
		2237
		2238	/*
		2239	* Create an instance - this will recursively execute the new object's
		2240	* constructor, if it has one. Note that we have one more argument
		2241	* than provided by the caller, because we've pushed the implicit
		2242	* argument ('self') that create_from_stack uses to identify the
		2243	* superclass.
		2244	*/
		2245	retval->set_obj(create_from_stack_intern(vmg_ 0, argc + 1,
		2246	is_transient));
		2247
		2248	/* handled */
		2249	return TRUE;
		2250	}
		2251
		2252	/* ------------------------------------------------------------------------ */
		2253	/*
		2254	* Property evaluator - createClone
		2255	*/
		2256	int CVmObjTads::getp_create_clone(VMG_ vm_obj_id_t self,
		2257	vm_val_t retval, uint argc)
		2258	{
		2259	static CVmNativeCodeDesc desc(0);
		2260	vm_obj_id_t new_obj;
		2261	CVmObjTads *tobj;
		2262	vm_tadsobj_prop *entry;
		2263	ushort i;
		2264	vm_tadsobj_hdr *hdr = get_hdr();
		2265
		2266	/* check arguments */
		2267	if (get_prop_check_argc(retval, argc, &desc))
		2268	return TRUE;
		2269
		2270	/*
		2271	* create a new object with the same number of superclasses as I have,
		2272	* and with space for all of my properties
		2273	*/
		2274	new_obj = create(vmg_ FALSE, get_sc_count(), hdr->prop_entry_free);
		2275	tobj = (CVmObjTads *)vm_objp(vmg_ new_obj);
		2276
		2277	/* copy my superclass list to the new object */
		2278	for (i = 0 ; i < get_sc_count() ; ++i)
		2279	tobj->set_sc(vmg_ i, get_sc(i));
		2280
		2281	/* copy my properties to the new object */
		2282	for (i = hdr->prop_entry_free, entry = hdr->prop_entry_arr ;
		2283	i != 0 ; --i, ++entry)
		2284	{
		2285	/*
		2286	* If this entry is non-empty, store the property in the new
		2287	* object. We don't need to store undo for the property, as the
		2288	* object is entirely new since the last savepoint (as there can't
		2289	* have been a savepoint while we've been working, obviously)
		2290	*/
		2291	if (entry->val.typ != VM_EMPTY)
		2292	tobj->set_prop(vmg_ 0, self, entry->prop, &entry->val);
		2293	}
		2294
		2295	/* the return value is the new object ID */
		2296	retval->set_obj(new_obj);
		2297
		2298	/* handled */
		2299	return TRUE;
		2300	}
		2301
		2302	/* ------------------------------------------------------------------------ */
		2303	/*
		2304	* Property evaluator - createInstanceOf
		2305	*/
		2306	int CVmObjTads::getp_create_instance_of(VMG_ vm_obj_id_t self,
		2307	vm_val_t retval, uint in_argc)
		2308	{
		2309	/* create a persistent instance */
		2310	return getp_create_multi_common(vmg_ self, retval, in_argc, FALSE);
		2311	}
		2312
		2313	/*
		2314	* Property evaluator - createTransientInstanceOf
		2315	*/
		2316	int CVmObjTads::getp_create_trans_instance_of(
		2317	VMG_ vm_obj_id_t self, vm_val_t retval, uint in_argc)
		2318	{
		2319	/* create a persistent instance */
		2320	return getp_create_multi_common(vmg_ self, retval, in_argc, TRUE);
		2321	}
		2322
		2323	/*
		2324	* Common handler for createInstanceOf() and createTransientInstanceOf()
		2325	*/
		2326	int CVmObjTads::getp_create_multi_common(VMG_ vm_obj_id_t self,
		2327	vm_val_t retval, uint in_argc,
		2328	int is_transient)
		2329	{
		2330	uint argc = (in_argc != 0 ? *in_argc : 0);
		2331	static CVmNativeCodeDesc desc(0, 0, TRUE);
		2332
		2333	/* check arguments - any number are allowed */
		2334	if (get_prop_check_argc(retval, in_argc, &desc))
		2335	return TRUE;
		2336
		2337	/* create the new instance */
		2338	retval->set_obj(create_from_stack_multi(vmg_ argc, is_transient));
		2339
		2340	/* handled */
		2341	return TRUE;
		2342	}
		2343
		2344	/* ------------------------------------------------------------------------ */
		2345	/*
		2346	* Property evaluator - setSuperclassList
		2347	*/
		2348	int CVmObjTads::getp_set_sc_list(VMG_ vm_obj_id_t self,
		2349	vm_val_t retval, uint in_argc)
		2350	{
		2351	static CVmNativeCodeDesc desc(1);
		2352	const char *lstp;
		2353	ushort cnt;
		2354	size_t i;
		2355	vm_val_t ele;
		2356	ushort sc_cnt;
		2357	vm_tadsobj_hdr *hdr = get_hdr();
		2358
		2359	/* check arguments */
		2360	if (get_prop_check_argc(retval, in_argc, &desc))
		2361	return TRUE;
		2362
		2363	/* get the list argument (but leave it on the stack for now) */
		2364	lstp = G_stk->get(0)->get_as_list(vmg0_);
		2365	if (lstp == 0)
		2366	err_throw(VMERR_BAD_TYPE_BIF);
		2367
		2368	/* get the number of superclasses for the new object */
		2369	cnt = (ushort)vmb_get_len(lstp);
		2370
		2371	/* we need at least one argument - the minimal root is TadsObject */
		2372	if (cnt < 1)
		2373	err_throw(VMERR_BAD_VAL_BIF);
		2374
		2375	/*
		2376	* Check for a special case: our entire superclass list consists of
		2377	* [TadsObject]. In this case, we have nothing in our internal
		2378	* superclass list, since our only superclass is our metaclass.
		2379	*/
		2380	CVmObjList::index_list(vmg_ &ele, lstp, 1);
		2381	if (cnt == 1
		2382	&& ele.typ == VM_OBJ
		2383	&& ele.val.obj == metaclass_reg_->get_class_obj(vmg0_))
		2384	{
		2385	/* use an empty internal superclass list */
		2386	sc_cnt = 0;
		2387	}
		2388	else
		2389	{
		2390	/*
		2391	* Scan the superclasses. Each superclass must be a TadsObject,
		2392	* with the one exception that if we have only one superclass, it
		2393	* can be the TadsObject intrinsic class itself, signifying that we
		2394	* have no superclasses.
		2395	*/
		2396	for (i = 1 ; i <= cnt ; ++i)
		2397	{
		2398	/* get this element from the list */
		2399	CVmObjList::index_list(vmg_ &ele, lstp, i);
		2400
		2401	/* it has to be an object of type TadsObject */
		2402	if (ele.typ != VM_OBJ \|\| !is_tadsobj_obj(vmg_ ele.val.obj))
		2403	err_throw(VMERR_BAD_VAL_BIF);
		2404
		2405	/*
		2406	* make sure that this superclass doesn't inherit from 'self' -
		2407	* if it does, that would create a circular inheritance
		2408	* hierarchy, which is illegal
		2409	*/
		2410	if (vm_objp(vmg_ ele.val.obj)->is_instance_of(vmg_ self))
		2411	err_throw(VMERR_BAD_VAL_BIF);
		2412	}
		2413
		2414	/* the list is valid - we need one superclass per list element */
		2415	sc_cnt = cnt;
		2416	}
		2417
		2418	/* if there's a system undo object, add undo for the change */
		2419	if (G_undo != 0)
		2420	{
		2421	vm_val_t oldv;
		2422	CVmObjList *oldp;
		2423
		2424	/* allocate a list for the results */
		2425	oldv.set_obj(CVmObjList::create(vmg_ FALSE, hdr->sc_cnt));
		2426	oldp = (CVmObjList *)vm_objp(vmg_ oldv.val.obj);
		2427
		2428	/* build the superclass list */
		2429	for (i = 0 ; i < hdr->sc_cnt ; ++i)
		2430	{
		2431	/* add this superclass to the list */
		2432	ele.set_obj(hdr->sc[i].id);
		2433	oldp->cons_set_element(i, &ele);
		2434	}
		2435
		2436	/*
		2437	* Add an undo record with the original superclass list as the old
		2438	* value. Use the 'invalid' property as the proprety key - all of
		2439	* our other undo records are associated with actual properties, so
		2440	* this is how we know this is an undo record for the superclass
		2441	* list.
		2442	*/
		2443	G_undo->add_new_record_prop_key(vmg_ self, VM_INVALID_PROP, &oldv);
		2444	}
		2445
		2446	/* update the superclass list with the given list */
		2447	change_superclass_list(vmg_ lstp, sc_cnt);
		2448
		2449	/* discard arguments */
		2450	G_stk->discard();
		2451
		2452	/* no return value */
		2453	retval->set_nil();
		2454
		2455	/* handled */
		2456	return TRUE;
		2457	}
		2458
		2459	/*
		2460	* Change the superclass list to the given list. 'lstp' is the new
		2461	* superclass list, in constant list format (i.e., a packed array of
		2462	* dataholder values).
		2463	*/
		2464	void CVmObjTads::change_superclass_list(VMG_ const char *lstp, ushort cnt)
		2465	{
		2466	vm_tadsobj_hdr *hdr = get_hdr();
		2467	size_t i;
		2468
		2469	/*
		2470	* if we're increasing the number of superclasses, expand our object
		2471	* header to make room
		2472	*/
		2473	if (cnt > hdr->sc_cnt)
		2474	{
		2475	/* expand the header to accomodate the new superclass list */
		2476	ext_ = (char *)vm_tadsobj_hdr::expand_to(
		2477	vmg_ this, hdr, cnt, hdr->prop_entry_cnt);
		2478
		2479	/* get the new header */
		2480	hdr = get_hdr();
		2481	}
		2482
		2483	/* set the new superclass count */
		2484	hdr->sc_cnt = cnt;
		2485
		2486	/* set the new superclasses */
		2487	for (i = 0 ; i < cnt ; ++i)
		2488	{
		2489	vm_val_t ele;
		2490
		2491	/* get this element from the list */
		2492	CVmObjList::index_list(vmg_ &ele, lstp, i + 1);
		2493
		2494	/* set this superclass in the header */
		2495	hdr->sc[i].id = ele.val.obj;
		2496	hdr->sc[i].objp = (CVmObjTads *)vm_objp(vmg_ ele.val.obj);
		2497	}
		2498
		2499	/* invalidate the cached inheritance path */
		2500	hdr->inval_inh_path();
		2501	}
		2502
		2503	/* ------------------------------------------------------------------------ */
		2504	/*
		2505	* Intrinsic Class Modifier object implementation
		2506	*/
		2507
		2508	/* metaclass registration object */
		2509	static CVmMetaclassIntClsMod metaclass_reg_obj_icm;
		2510	CVmMetaclass *CVmObjIntClsMod::metaclass_reg_ = &metaclass_reg_obj_icm;
		2511
		2512	/*
		2513	* Get a property. Intrinsic class modifiers do not have intrinsic
		2514	* superclasses, because they're effectively mix-in classes. Therefore,
		2515	* do not look for intrinsic properties or intrinsic superclass properties
		2516	* to resolve the property lookup.
		2517	*/
		2518	int CVmObjIntClsMod::get_prop(VMG_ vm_prop_id_t prop, vm_val_t *val,
		2519	vm_obj_id_t self, vm_obj_id_t *source_obj,
		2520	uint *argc)
		2521	{
		2522	/*
		2523	* try finding the property in our property list or a superclass
		2524	* property list
		2525	*/
		2526	tadsobj_sc_search_ctx curpos(vmg_ self, this);
		2527	if (curpos.find_prop(vmg_ prop, val, source_obj))
		2528	return TRUE;
		2529
		2530	/*
		2531	* We didn't find it in our list, so we don't have the property.
		2532	* Because we're an intrinsic mix-in, we don't look for an intrinsic
		2533	* implementation or an intrinsic superclass implementation.
		2534	*/
		2535	return FALSE;
		2536	}
		2537
		2538	/*
		2539	* Inherit a property. As with get_prop(), we don't want to inherit from
		2540	* any intrinsic superclass if we don't find the property in our property
		2541	* list or an inherited property list.
		2542	*/
		2543	int CVmObjIntClsMod::inh_prop(VMG_ vm_prop_id_t prop, vm_val_t *val,
		2544	vm_obj_id_t self,
		2545	vm_obj_id_t orig_target_obj,
		2546	vm_obj_id_t defining_obj,
		2547	vm_obj_id_t source_obj, uint argc)
		2548	{
		2549	/*
		2550	* try finding the property in our property list or a superclass
		2551	* property list
		2552	*/
		2553	if (search_for_prop_from(vmg_ prop, val, orig_target_obj,
		2554	source_obj, defining_obj))
		2555	return TRUE;
		2556
		2557	/*
		2558	* we didn't find it in our list, and we don't want to inherit from any
		2559	* intrinsic superclass, so we don't have the property
		2560	*/
		2561	return FALSE;
		2562	}
		2563
		2564	/*
		2565	* Build my property list. We build the complete list of methods defined
		2566	* in the intrinsic class modifier for all classes, including any modify
		2567	* base classes that we further modify.
		2568	*/
		2569	void CVmObjIntClsMod::build_prop_list(VMG_ vm_obj_id_t self, vm_val_t *retval)
		2570	{
		2571	/* push a self-reference for gc protection */
		2572	G_stk->push()->set_obj(self);
		2573
		2574	/* build our own list */
		2575	CVmObjTads::build_prop_list(vmg_ self, retval);
		2576
		2577	/* if we have a base class that we further modify, add its list */
		2578	if (get_sc_count() != 0)
		2579	{
		2580	vm_obj_id_t base_id;
		2581	CVmObject *base_obj;
		2582
		2583	/* get the base class */
		2584	base_id = get_sc(0);
		2585	base_obj = vm_objp(vmg_ base_id);
		2586
		2587	/* get its list only if it's of our same metaclass */
		2588	if (base_obj->get_metaclass_reg() == get_metaclass_reg())
		2589	{
		2590	vm_val_t base_val;
		2591
		2592	/* save our list for gc protection */
		2593	G_stk->push(retval);
		2594
		2595	/* get our base class's list */
		2596	base_obj->build_prop_list(vmg_ base_id, &base_val);
		2597
		2598	/* add this list to our result list */
		2599	vm_objp(vmg_ retval->val.obj)->
		2600	add_val(vmg_ retval, retval->val.obj, &base_val);
		2601
		2602	/* discard our gc protection */
		2603	G_stk->discard();
		2604	}
		2605	}
		2606
		2607	/* discard gc protection */
		2608	G_stk->discard();
		2609	}

FrobTADS

cfad47cfa3/tads3/vmtobj.cpp