itcl3-dev 3.4.3-1 / usr / include / itcl3 / itclInt.h

/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  [incr Tcl] provides object-oriented extensions to Tcl, much as
 *  C++ provides object-oriented extensions to C.  It provides a means
 *  of encapsulating related procedures together with their shared data
 *  in a local namespace that is hidden from the outside world.  It
 *  promotes code re-use through inheritance.  More than anything else,
 *  it encourages better organization of Tcl applications through the
 *  object-oriented paradigm, leading to code that is easier to
 *  understand and maintain.
 *  
 *  ADDING [incr Tcl] TO A Tcl-BASED APPLICATION:
 *
 *    To add [incr Tcl] facilities to a Tcl application, modify the
 *    Tcl_AppInit() routine as follows:
 *
 *    1) Include this header file near the top of the file containing
 *       Tcl_AppInit():
 *
 *         #include "itcl.h"
 *
 *    2) Within the body of Tcl_AppInit(), add the following lines:
 *
 *         if (Itcl_Init(interp) == TCL_ERROR) {
 *             return TCL_ERROR;
 *         }
 * 
 *    3) Link your application with libitcl.a
 *
 *    NOTE:  An example file "tclAppInit.c" containing the changes shown
 *           above is included in this distribution.
 *  
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *           Bell Labs Innovations for Lucent Technologies
 *           mmclennan@lucent.com
 *           http://www.tcltk.com/itcl
 * ========================================================================
 *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#ifndef ITCLINT_H
#define ITCLINT_H

#include "tclInt.h"
#include "itcl.h"

#ifdef BUILD_itcl
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
#endif

/*
 * Handle hiding of errorLine in 8.6
 */
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
#define Tcl_GetErrorLine(interp) ((interp)->errorLine)
#endif

#define ITCL_TCL_PRE_8_5 (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5)

#define ItclCallFrame CallFrame

#if !ITCL_TCL_PRE_8_5

#define Itcl_CallFrame Tcl_CallFrame

#if defined(USE_TCL_STUBS)

/*
 * Fix Tcl bug #803489 the right way.  We need to always use the old Stub
 * slot positions, not the new broken ones part of TIP 127.  I do like
 * that these functions have moved to the public space (about time), but
 * the slot change is the killer and is the painful side affect.
 */

#   undef Tcl_CreateNamespace
#   define Tcl_CreateNamespace \
	(tclIntStubsPtr->tcl_CreateNamespace)
#   undef Tcl_DeleteNamespace
#   define Tcl_DeleteNamespace \
	(tclIntStubsPtr->tcl_DeleteNamespace)
#   undef Tcl_AppendExportList
#   define Tcl_AppendExportList \
	(tclIntStubsPtr->tcl_AppendExportList)
#   undef Tcl_Export
#   define Tcl_Export \
	(tclIntStubsPtr->tcl_Export)
#   undef Tcl_Import
#   define Tcl_Import \
	(tclIntStubsPtr->tcl_Import)
#   undef Tcl_ForgetImport
#   define Tcl_ForgetImport \
	(tclIntStubsPtr->tcl_ForgetImport)
#   undef Tcl_GetCurrentNamespace
#   define Tcl_GetCurrentNamespace \
	(tclIntStubsPtr->tcl_GetCurrentNamespace)
#   undef Tcl_GetGlobalNamespace
#   define Tcl_GetGlobalNamespace \
	(tclIntStubsPtr->tcl_GetGlobalNamespace)
#   undef Tcl_FindNamespace
#   define Tcl_FindNamespace \
	(tclIntStubsPtr->tcl_FindNamespace)
#   undef Tcl_FindCommand
#   define Tcl_FindCommand \
	(tclIntStubsPtr->tcl_FindCommand)
#   undef Tcl_GetCommandFromObj
#   define Tcl_GetCommandFromObj \
	(tclIntStubsPtr->tcl_GetCommandFromObj)
#   undef Tcl_GetCommandFullName
#   define Tcl_GetCommandFullName \
	(tclIntStubsPtr->tcl_GetCommandFullName)
#endif /* use stubs */

#define ItclInitVarFlags(varPtr) \
    (varPtr)->flags = 0

#define ItclInitVarArgument(varPtr) \
   (varPtr)->flags = VAR_ARGUMENT 

#define ItclVarHashCreateVar(tablePtr, key, newPtr) \
    TclVarHashCreateVar((tablePtr), (key), (newPtr))

#define ItclVarRefCount(varPtr) VarHashRefCount(varPtr)

#define ItclClearVarUndefined(varPtr)

#define ItclNextLocal(varPtr) ((varPtr)++)

#define ItclVarObjValue(varPtr) ((varPtr)->value.objPtr)

#define itclVarInHashSize sizeof(VarInHash)
#define itclVarLocalSize  sizeof(Var)

#else /* Compiling on Tcl8.x, x<5 */ 

typedef struct Itcl_CallFrame {
    Tcl_Namespace *nsPtr;
    int dummy1;
    int dummy2;
    void *dummy3;
    void *dummy4;
    void *dummy5;
    int dummy6;
    void *dummy7;
    void *dummy8;
    int dummy9;
    void *dummy10;
    void *dummy11;
    void *dummy12;
    void *dummy13;
} Itcl_CallFrame;

/*
 * Definition of runtime behaviour to be able to run irrespective of the Tcl
 * version.
 */

#define VarInHash Var

#define TclVarHashTable Tcl_HashTable

typedef struct ItclShortVar {
    int flags;
    union {
	Tcl_Obj *objPtr;
	TclVarHashTable *tablePtr;
	struct Var *linkPtr;
    } value;
} ItclShortVar;

typedef struct ItclVarInHash {
    ItclShortVar var;
    int refCount;
    Tcl_HashEntry entry;
} ItclVarInHash;

#define ItclOffset(type, field) ((int) ((char *) &((type *) 0)->field))

#define itclOldRuntime (itclVarFlagOffset!=0)

extern int itclVarFlagOffset; 
extern int itclVarRefCountOffset;
extern int itclVarInHashSize;
extern int itclVarLocalSize;
extern int itclVarValueOffset;

/*
 * VarReform related macros: provide access to the Var fields with offsets
 * determined at load time, so that the same code copes with the different
 * structs in Tcl8.5 and previous Tcl.
 */

#define ItclNextLocal(varPtr) \
    ((varPtr) = (Var *) (((char *)(varPtr))+itclVarLocalSize))

#define ItclVarObjValue(varPtr) \
    (*((Tcl_Obj **) (((char *)(varPtr))+itclVarValueOffset)))

#define ItclVarRefCount(varPtr) \
    (*((int *) (((char *)(varPtr))+itclVarRefCountOffset)))

#define ItclVarFlags(varPtr) \
    (*((int *)(((char *)(varPtr))+itclVarFlagOffset)))

/* Note that itclVarFlagOffset==0 exactly when we are running in Tcl8.5 */
#define ItclInitVarFlags(varPtr) \
    if (itclOldRuntime) { \
	(varPtr)->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);\
    } else { \
        ((ItclShortVar *)(varPtr))->flags = 0;\
    }

/* This is used for CompiledLocal, not for Var & Co. That struct did not
 * change, but the correct flag init did! The flags bits themselves are
 * unchanged */

#define ItclInitVarArgument(varPtr) \
    if (itclOldRuntime) { \
	(varPtr)->flags = (VAR_SCALAR | VAR_ARGUMENT);\
    } else { \
	(varPtr)->flags = VAR_ARGUMENT;\
    }

#define TclIsVarNamespaceVar(varPtr) \
    (ItclVarFlags(varPtr) & VAR_NAMESPACE_VAR)

#define TclSetVarNamespaceVar(varPtr) \
    if (!TclIsVarNamespaceVar(varPtr)) {\
        ItclVarFlags(varPtr) |= VAR_NAMESPACE_VAR;\
        ItclVarRefCount(varPtr)++;\
    }

#define ItclClearVarUndefined(varPtr) \
    if (itclOldRuntime) { \
	ItclVarFlags(varPtr) &= ~VAR_UNDEFINED;\
    }

#ifndef MODULE_SCOPE
#define MODULE_SCOPE
#endif

MODULE_SCOPE Var * ItclVarHashCreateVar (TclVarHashTable * tablePtr, 
				const char * key, int * newPtr);

#endif /* Version dependent defs and macros */


#define ItclVarHashFindVar(tablePtr, key) \
    ItclVarHashCreateVar((tablePtr), (key), NULL)


/*
 *  Common info for managing all known objects.
 *  Each interpreter has one of these data structures stored as
 *  clientData in the "itcl" namespace.  It is also accessible
 *  as associated data via the key ITCL_INTERP_DATA.
 */
struct ItclObject;
typedef struct ItclObjectInfo {
    Tcl_Interp *interp;             /* interpreter that manages this info */
    Tcl_HashTable objects;          /* list of all known objects */

    Itcl_Stack transparentFrames;   /* stack of call frames that should be
                                     * treated transparently.  When
                                     * Itcl_EvalMemberCode is invoked in
                                     * one of these contexts, it does an
                                     * "uplevel" to get past the transparent
                                     * frame and back to the calling context. */
    Tcl_HashTable contextFrames;    /* object contexts for active call frames */

    int protection;                 /* protection level currently in effect */

    Itcl_Stack cdefnStack;          /* stack of class definitions currently
                                     * being parsed */
} ItclObjectInfo;

#define ITCL_INTERP_DATA "itcl_data"

/*
 *  Representation for each [incr Tcl] class.
 */
typedef struct ItclClass {
    char *name;                   /* class name */
    char *fullname;               /* fully qualified class name */
    Tcl_Interp *interp;           /* interpreter that manages this info */
    Tcl_Namespace *namesp;        /* namespace representing class scope */
    Tcl_Command accessCmd;        /* access command for creating instances */

    struct ItclObjectInfo *info;  /* info about all known objects */
    Itcl_List bases;              /* list of base classes */
    Itcl_List derived;            /* list of all derived classes */
    Tcl_HashTable heritage;       /* table of all base classes.  Look up
                                   * by pointer to class definition.  This
                                   * provides fast lookup for inheritance
                                   * tests. */
    Tcl_Obj *initCode;            /* initialization code for new objs */
    Tcl_HashTable variables;      /* definitions for all data members
                                     in this class.  Look up simple string
                                     names and get back ItclVarDefn* ptrs */
    Tcl_HashTable functions;      /* definitions for all member functions
                                     in this class.  Look up simple string
                                     names and get back ItclMemberFunc* ptrs */
    int numInstanceVars;          /* number of instance vars in variables
                                     table */
    Tcl_HashTable resolveVars;    /* all possible names for variables in
                                   * this class (e.g., x, foo::x, etc.) */
    Tcl_HashTable resolveCmds;    /* all possible names for functions in
                                   * this class (e.g., x, foo::x, etc.) */
    int unique;                   /* unique number for #auto generation */
    int flags;                    /* maintains class status */
} ItclClass;

typedef struct ItclHierIter {
    ItclClass *current;           /* current position in hierarchy */
    Itcl_Stack stack;             /* stack used for traversal */
} ItclHierIter;

/*
 *  Representation for each [incr Tcl] object.
 */
typedef struct ItclObject {
    ItclClass *classDefn;        /* most-specific class */
    Tcl_Command accessCmd;       /* object access command */

    int dataSize;                /* number of elements in data array */
    Var** data;                  /* all object-specific data members */
    Tcl_HashTable* constructed;  /* temp storage used during construction */
    Tcl_HashTable* destructed;   /* temp storage used during destruction */
} ItclObject;

#define ITCL_IGNORE_ERRS  0x002  /* useful for construction/destruction */

/*
 *  Implementation for any code body in an [incr Tcl] class.
 */
typedef struct ItclMemberCode {
    int flags;                  /* flags describing implementation */
    CompiledLocal *arglist;     /* list of arg names and initial values */
    int argcount;               /* number of args in arglist */
    Proc *procPtr;              /* Tcl proc representation (needed to
                                 * handle compiled locals) */
    union {
        Tcl_CmdProc *argCmd;    /* (argc,argv) C implementation */
        Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */
    } cfunc;

    ClientData clientData;      /* client data for C implementations */

} ItclMemberCode;

#define Itcl_IsMemberCodeImplemented(mcode) \
    (((mcode)->flags & ITCL_IMPLEMENT_NONE) == 0)

/*
 *  Basic representation for class members (commands/variables)
 */
typedef struct ItclMember {
    Tcl_Interp* interp;         /* interpreter containing the class */
    ItclClass* classDefn;       /* class containing this member */
    char* name;                 /* member name */
    char* fullname;             /* member name with "class::" qualifier */
    int protection;             /* protection level */
    int flags;                  /* flags describing member (see below) */
    ItclMemberCode *code;       /* code associated with member */
} ItclMember;

/*
 *  Flag bits for ItclMemberCode and ItclMember:
 */
#define ITCL_IMPLEMENT_NONE    0x001  /* no implementation */
#define ITCL_IMPLEMENT_TCL     0x002  /* Tcl implementation */
#define ITCL_IMPLEMENT_ARGCMD  0x004  /* (argc,argv) C implementation */
#define ITCL_IMPLEMENT_OBJCMD  0x008  /* (objc,objv) C implementation */
#define ITCL_IMPLEMENT_C       0x00c  /* either kind of C implementation */
#define ITCL_CONSTRUCTOR       0x010  /* non-zero => is a constructor */
#define ITCL_DESTRUCTOR        0x020  /* non-zero => is a destructor */
#define ITCL_COMMON            0x040  /* non-zero => is a "proc" */
#define ITCL_ARG_SPEC          0x080  /* non-zero => has an argument spec */

#define ITCL_OLD_STYLE         0x100  /* non-zero => old-style method
                                       * (process "config" argument) */

#define ITCL_THIS_VAR          0x200  /* non-zero => built-in "this" variable */

/*
 *  Representation of member functions in an [incr Tcl] class.
 */
typedef struct ItclMemberFunc {
    ItclMember *member;          /* basic member info */
    Tcl_Command accessCmd;       /* Tcl command installed for this function */
    CompiledLocal *arglist;      /* list of arg names and initial values */
    int argcount;                /* number of args in arglist */
} ItclMemberFunc;

/*
 *  Instance variables.
 */
typedef struct ItclVarDefn {
    ItclMember *member;          /* basic member info */
    char* init;                  /* initial value */
} ItclVarDefn;

/*
 *  Instance variable lookup entry.
 */
typedef struct ItclVarLookup {
    ItclVarDefn* vdefn;       /* variable definition */
    int usage;                /* number of uses for this record */
    int accessible;           /* non-zero => accessible from class with
                               * this lookup record in its resolveVars */
    char *leastQualName;      /* simplist name for this variable, with
                               * the fewest qualifiers.  This string is
                               * taken from the resolveVars table, so
                               * it shouldn't be freed. */
    union {
        int index;            /* index into virtual table (instance data) */
        Tcl_Var common;       /* variable (common data) */
    } var;
} ItclVarLookup;

/*
 *  Representation for the context in which a body of [incr Tcl]
 *  code executes.  In ordinary Tcl, this is a CallFrame.  But for
 *  [incr Tcl] code bodies, we must be careful to set up the
 *  CallFrame properly, to plug in instance variables before
 *  executing the code body.
 */
typedef struct ItclContext {
    ItclClass *classDefn;     /* class definition */
    Itcl_CallFrame frame;      /* call frame for object context */
    Var *compiledLocals;      /* points to storage for compiled locals */
    Var localStorage[20];     /* default storage for compiled locals */
} ItclContext;

/*
 *  Compatibility flags.  Used to support small "hacks".  These are stored
 *  in the global variable named itclCompatFlags.
 */

extern int itclCompatFlags;

#define ITCL_COMPAT_USE_ISTATE_API 0x2  /* Tcl 8.5a2 added interp state APIs */

#include "itclIntDecls.h"

/*
 * Since the Tcl/Tk distribution doesn't perform any asserts,
 * dynamic loading can fail to find the __assert function.
 * As a workaround, we'll include our own.
 */

#undef  assert
#ifndef  DEBUG
#define assert(EX) ((void)0)
#else
#define assert(EX) (void)((EX) || (Itcl_Assert(STRINGIFY(EX), __FILE__, __LINE__), 0))
#endif  /* DEBUG */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* ITCLINT_H */