/* extern.c - external type support for xlisp 2.0 *//* Description of external types:        A new node type EXTERN has been created to allow extensions to thexlisp type system.  If a node is of type EXTERN then it contains two fields:(1) a pointer to a type descriptor, and (2) a value which is normally a pointerto an instance of the data type.        The type descriptor has 6 fields:type_name: a string name for the typetype_symbol: a pointer to a symbol whose print name is type_namefree_meth: routine to call when the node is freedprint_meth: routine to call to print the nodesave_meth: routine to save the value to a filerestore_meth: routine to restore the value from a file        The routine create_desc() is used to allocate and initialize a typedescriptor.  There should be only one type descriptor for each unique type.Typically, the module that manages a type will create the type descriptorat initialization time.        The routine cvextern() is used to combine a type descriptor and avalue to create an EXTERN node that can be used by xlisp.  This routine iscalled whenever a new value is allocated and returned to xlisp.        The routine exttype() returns the type symbol for an EXTERN type.        The routine exttypep() tests for a type match.        If EXTERN objects are dynamically allocated and freed, then thereshould only be one EXTERN node whose value field (xe_inst) points to the object.If there is more than one node (normally created only by cvextern), then oneof the following should hold:1. the object is not dynamically freed.2. the object is reference counted and freed when the last EXTERN node is gc'd.3. the object will be freed when the first node pointing to it is gc'd, resultingin a dangling pointer bug.        The save and restore capability of xlisp version 2.0 causes somedifficulties in that symbols get relocated whenever a workspace is loaded.However, type descriptors must point to symbols and type descriptors must bepresent in order to load external types from a workspace.  My solution to thisproblem is to store a string name for each type and also to cache a pointerto the corresponding symbol.  The cache is invalidated whenever a workspace isloaded (causing symbols to be reallocated).  To make it possible to save andrestore references to type descriptors, all type descriptors are kept instatic storage.  Internally, they are referenced by pointers, but when saved,an integer index is used.  Because of the integer index, types must always beallocated in the same order.  This is taken care of in localinit().*/#include "xlisp.h"#include "extern.h"int extindex = 0;struct xtype_desc_struct desc_table[NTYPES];/* create_desc - create a new external type *//**/xtype_desc create_desc(  char *type_name,	/* the type string name */  void (*fm)(),		/* method to free instances of the type */  void (*pm)(),		/* method to print instances of the type */  void (*sm)(),		/* method to save instances of the type */  unsigned char * (*rm)(), /* method to restore instances of the type */  void (*mm)())		/* method to mark instances of the type for GC */{    xtype_desc td;	/* the new type descriptor */    if (extindex >= NTYPES) xlfail("insufficient type desc space");    td = &desc_table[extindex++];    td->type_name = type_name;    td->type_symbol = NULL;    td->free_meth = fm;    td->print_meth = pm;    td->save_meth = sm;    td->restore_meth = rm;    td->mark_meth = mm;    return td;}/* cvextern - create an instance of some type *//**/LVAL cvextern(typeptr, instptr)  xtype_desc typeptr;	/* pointer to type descriptor */  unsigned char *instptr;	/* pointer to the data */{    LVAL xnode;	/* the resulting lisp node */    xnode = newnode(EXTERN);    setdesc(xnode, typeptr);    setinst(xnode, instptr);    return xnode;}/* exttype -- get the type of an EXTERN *//**/LVAL exttype(x)  LVAL x;{    if (!(getdesc(x)->type_symbol)) {        getdesc(x)->type_symbol = xlenter(getdesc(x)->type_name);    }    return getdesc(x)->type_symbol;}/* exttypep -- test for type match *//* * x is a node, type_sym is a symbol */int exttypep(LVAL x, LVAL type_sym){    if ((x) && ntype(x) == EXTERN) {        if (!(getdesc(x)->type_symbol)) {            getdesc(x)->type_symbol = xlenter(getdesc(x)->type_name);        }        return (getdesc(x)->type_symbol == type_sym);    }    return FALSE;}/* inval_caches -- set type_symbol fields to NULL *//**/void inval_caches(){    int i;    for (i = 0; i < extindex; i++) {        desc_table[i].type_symbol = NULL;    }}