File: itclMethod.c

package info (click to toggle)
itcl4 4.3.5-1
links: PTS, VCS
area: main
in suites: forky, sid
size: 2,512 kB
sloc: ansic: 25,739; tcl: 1,705; sh: 452; makefile: 68
file content (2761 lines) | stat: -rw-r--r-- 84,800 bytes
/*
 * ------------------------------------------------------------------------
 *      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.
 *
 *  These procedures handle commands available within a class scope.
 *  In [incr Tcl], the term "method" is used for a procedure that has
 *  access to object-specific data, while the term "proc" is used for
 *  a procedure that has access only to common class data.
 *
 * ========================================================================
 *  AUTHOR:  Michael J. McLennan
 *	   Bell Labs Innovations for Lucent Technologies
 *	   mmclennan@lucent.com
 *	   http://www.tcltk.com/itcl
 *
 *  overhauled version author: Arnulf Wiedemann
 * ========================================================================
 *	   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.
 */
#include "itclInt.h"

static int EquivArgLists(Tcl_Interp *interp, ItclArgList *origArgs,
	ItclArgList *realArgs);
static int ItclCreateMemberCode(Tcl_Interp* interp, ItclClass *iclsPtr,
	const char* arglist, const char* body, ItclMemberCode** mcodePtr,
	Tcl_Obj *namePtr, int flags);
static int ItclCreateMemberFunc(Tcl_Interp* interp, ItclClass *iclsPtr,
	Tcl_Obj *namePtr, const char* arglist, const char* body,
	ItclMemberFunc** imPtrPtr, int flags);
static void FreeMemberCode(ItclMemberCode *mcodePtr);

/*
 * ------------------------------------------------------------------------
 *  Itcl_BodyCmd()
 *
 *  Invoked by Tcl whenever the user issues an "itcl::body" command to
 *  define or redefine the implementation for a class method/proc.
 *  Handles the following syntax:
 *
 *    itcl::body <class>::<func> <arglist> <body>
 *
 *  Looks for an existing class member function with the name <func>,
 *  and if found, tries to assign the implementation.  If an argument
 *  list was specified in the original declaration, it must match
 *  <arglist> or an error is flagged.  If <body> has the form "@name"
 *  then it is treated as a reference to a C handling procedure;
 *  otherwise, it is taken as a body of Tcl statements.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
static int
NRBodyCmd(
    TCL_UNUSED(void *),      /*  */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const *objv)    /* argument objects */
{
    Tcl_HashEntry *entry;
    Tcl_DString buffer;
    Tcl_Obj *objPtr;
    ItclClass *iclsPtr;
    ItclMemberFunc *imPtr;
    const char *head;
    const char *tail;
    const char *token;
    char *arglist;
    char *body;
    int status = TCL_OK;

    ItclShowArgs(2, "Itcl_BodyCmd", objc, objv);
    if (objc != 4) {
	token = Tcl_GetString(objv[0]);
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "wrong # args: should be \"",
	    token, " class::func arglist body\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    /*
     *  Parse the member name "namesp::namesp::class::func".
     *  Make sure that a class name was specified, and that the
     *  class exists.
     */
    token = Tcl_GetString(objv[1]);
    Itcl_ParseNamespPath(token, &buffer, &head, &tail);

    if (!head || *head == '\0') {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "missing class specifier for body declaration \"", token, "\"",
	    (char *)NULL);
	status = TCL_ERROR;
	goto bodyCmdDone;
    }

    iclsPtr = Itcl_FindClass(interp, head, /* autoload */ 1);
    if (iclsPtr == NULL) {
	status = TCL_ERROR;
	goto bodyCmdDone;
    }

    /*
     *  Find the function and try to change its implementation.
     *  Note that command resolution table contains *all* functions,
     *  even those in a base class.  Make sure that the class
     *  containing the method definition is the requested class.
     */

    imPtr = NULL;
    objPtr = Tcl_NewStringObj(tail, TCL_INDEX_NONE);
    entry = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
    Tcl_DecrRefCount(objPtr);
    if (entry) {
	ItclCmdLookup *clookup;
	clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
	imPtr = clookup->imPtr;
	if (imPtr->iclsPtr != iclsPtr) {
	    imPtr = NULL;
	}
    }

    if (imPtr == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "function \"", tail, "\" is not defined in class \"",
	    Tcl_GetString(iclsPtr->fullNamePtr), "\"",
	    (char *)NULL);
	status = TCL_ERROR;
	goto bodyCmdDone;
    }

    arglist = Tcl_GetString(objv[2]);
    body    = Tcl_GetString(objv[3]);

    if (Itcl_ChangeMemberFunc(interp, imPtr, arglist, body) != TCL_OK) {
	status = TCL_ERROR;
	goto bodyCmdDone;
    }

bodyCmdDone:
    Tcl_DStringFree(&buffer);
    return status;
}


int
Itcl_BodyCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return Tcl_NRCallObjProc(interp, NRBodyCmd, clientData, objc, objv);
}



/*
 * ------------------------------------------------------------------------
 *  Itcl_ConfigBodyCmd()
 *
 *  Invoked by Tcl whenever the user issues an "itcl::configbody" command
 *  to define or redefine the configuration code associated with a
 *  public variable.  Handles the following syntax:
 *
 *    itcl::configbody <class>::<publicVar> <body>
 *
 *  Looks for an existing public variable with the name <publicVar>,
 *  and if found, tries to assign the implementation.  If <body> has
 *  the form "@name" then it is treated as a reference to a C handling
 *  procedure; otherwise, it is taken as a body of Tcl statements.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */

static int
NRConfigBodyCmd(
    TCL_UNUSED(void *),      /* unused */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    int status = TCL_OK;

    const char *head;
    const char *tail;
    const char *token;
    Tcl_DString buffer;
    ItclClass *iclsPtr;
    ItclVarLookup *vlookup;
    ItclVariable *ivPtr;
    ItclMemberCode *mcode;
    Tcl_HashEntry *entry;

    ItclShowArgs(2, "Itcl_ConfigBodyCmd", objc, objv);
    if (objc != 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "class::option body");
	return TCL_ERROR;
    }

    /*
     *  Parse the member name "namesp::namesp::class::option".
     *  Make sure that a class name was specified, and that the
     *  class exists.
     */
    token = Tcl_GetString(objv[1]);
    Itcl_ParseNamespPath(token, &buffer, &head, &tail);

    if ((head == NULL) || (*head == '\0')) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "missing class specifier for body declaration \"", token, "\"",
	    (char *)NULL);
	status = TCL_ERROR;
	goto configBodyCmdDone;
    }

    iclsPtr = Itcl_FindClass(interp, head, /* autoload */ 1);
    if (iclsPtr == NULL) {
	status = TCL_ERROR;
	goto configBodyCmdDone;
    }

    /*
     *  Find the variable and change its implementation.
     *  Note that variable resolution table has *all* variables,
     *  even those in a base class.  Make sure that the class
     *  containing the variable definition is the requested class.
     */
    vlookup = NULL;
    entry = ItclResolveVarEntry(iclsPtr, tail);
    if (entry) {
	vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
	if (vlookup->ivPtr->iclsPtr != iclsPtr) {
	    vlookup = NULL;
	}
    }

    if (vlookup == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "option \"", tail, "\" is not defined in class \"",
	    Tcl_GetString(iclsPtr->fullNamePtr), "\"",
	    (char *)NULL);
	status = TCL_ERROR;
	goto configBodyCmdDone;
    }
    ivPtr = vlookup->ivPtr;

    if (ivPtr->protection != ITCL_PUBLIC) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		"option \"", Tcl_GetString(ivPtr->fullNamePtr),
		"\" is not a public configuration option",
		(char *)NULL);
	status = TCL_ERROR;
	goto configBodyCmdDone;
    }

    token = Tcl_GetString(objv[2]);

    if (Itcl_CreateMemberCode(interp, iclsPtr, NULL, token,
	    &mcode) != TCL_OK) {
	status = TCL_ERROR;
	goto configBodyCmdDone;
    }

    Itcl_PreserveData(mcode);

    if (ivPtr->codePtr) {
	Itcl_ReleaseData(ivPtr->codePtr);
    }
    ivPtr->codePtr = mcode;

configBodyCmdDone:
    Tcl_DStringFree(&buffer);
    return status;
}


int
Itcl_ConfigBodyCmd(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return Tcl_NRCallObjProc(interp, NRConfigBodyCmd, clientData, objc, objv);
}



/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateMethod()
 *
 *  Installs a method into the namespace associated with a class.
 *  If another command with the same name is already installed, then
 *  it is overwritten.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error message
 *  in the specified interp) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateMethod(
    Tcl_Interp* interp,  /* interpreter managing this action */
    ItclClass *iclsPtr,  /* class definition */
    Tcl_Obj *namePtr,    /* name of new method */
    const char* arglist, /* space-separated list of arg names */
    const char* body)    /* body of commands for the method */
{
    ItclMemberFunc *imPtr;

    return ItclCreateMethod(interp, iclsPtr, namePtr, arglist, body, &imPtr);
}

/*
 * ------------------------------------------------------------------------
 *  ItclCreateMethod()
 *
 *  Installs a method into the namespace associated with a class.
 *  If another command with the same name is already installed, then
 *  it is overwritten.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error message
 *  in the specified interp) if anything goes wrong.
 * ------------------------------------------------------------------------
 */
int
ItclCreateMethod(
    Tcl_Interp* interp,  /* interpreter managing this action */
    ItclClass *iclsPtr,  /* class definition */
    Tcl_Obj *namePtr,    /* name of new method */
    const char* arglist, /* space-separated list of arg names */
    const char* body,    /* body of commands for the method */
    ItclMemberFunc **imPtrPtr)
{
    ItclMemberFunc *imPtr;

    /*
     *  Make sure that the method name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    if (strstr(Tcl_GetString(namePtr),"::")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "bad method name \"", Tcl_GetString(namePtr), "\"",
	    (char *)NULL);
	Tcl_DecrRefCount(namePtr);
	return TCL_ERROR;
    }

    /*
     *  Create the method definition.
     */
    if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist, body,
	    &imPtr, 0) != TCL_OK) {
	return TCL_ERROR;
    }

    imPtr->flags |= ITCL_METHOD;
    if (imPtrPtr != NULL) {
	*imPtrPtr = imPtr;
    }
    ItclAddClassFunctionDictInfo(interp, iclsPtr, imPtr);
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateProc()
 *
 *  Installs a class proc into the namespace associated with a class.
 *  If another command with the same name is already installed, then
 *  it is overwritten.  Returns TCL_OK on success, or TCL_ERROR  (along
 *  with an error message in the specified interp) if anything goes
 *  wrong.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateProc(
    Tcl_Interp* interp,  /* interpreter managing this action */
    ItclClass *iclsPtr,  /* class definition */
    Tcl_Obj* namePtr,    /* name of new proc */
    const char *arglist, /* space-separated list of arg names */
    const char *body)    /* body of commands for the proc */
{
    ItclMemberFunc *imPtr;

    /*
     *  Make sure that the proc name does not contain anything
     *  goofy like a "::" scope qualifier.
     */
    if (strstr(Tcl_GetString(namePtr),"::")) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "bad proc name \"", Tcl_GetString(namePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    /*
     *  Create the proc definition.
     */
    if (ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist,
	    body, &imPtr, ITCL_COMMON) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     *  Mark procs as "common".  This distinguishes them from methods.
     */
    imPtr->flags |= ITCL_COMMON;
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclCreateMemberFunc()
 *
 *  Creates the data record representing a member function.  This
 *  includes the argument list and the body of the function.  If the
 *  body is of the form "@name", then it is treated as a label for
 *  a C procedure registered by Itcl_RegisterC().
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and "imPtr" returns a pointer to the new
 *  member function.
 * ------------------------------------------------------------------------
 */
static int
ItclCreateMemberFunc(
    Tcl_Interp* interp,	    /* interpreter managing this action */
    ItclClass *iclsPtr,	    /* class definition */
    Tcl_Obj *namePtr,	      /* name of new member */
    const char* arglist,	   /* space-separated list of arg names */
    const char* body,	      /* body of commands for the method */
    ItclMemberFunc** imPtrPtr,     /* returns: pointer to new method defn */
    int flags)
{
    int newEntry;
    char *name;
    ItclMemberFunc *imPtr;
    ItclMemberCode *mcode;
    Tcl_HashEntry *hPtr;

    /*
     *  Add the member function to the list of functions for
     *  the class.  Make sure that a member function with the
     *  same name doesn't already exist.
     */
    hPtr = Tcl_CreateHashEntry(&iclsPtr->functions, (char *)namePtr, &newEntry);
    if (!newEntry) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "\"", Tcl_GetString(namePtr), "\" already defined in class \"",
	    Tcl_GetString(iclsPtr->fullNamePtr), "\"",
	    (char *)NULL);
	return TCL_ERROR;
    }

    /*
     *  Try to create the implementation for this command member.
     */
    if (ItclCreateMemberCode(interp, iclsPtr, arglist, body,
	&mcode, namePtr, flags) != TCL_OK) {

	Tcl_DeleteHashEntry(hPtr);
	return TCL_ERROR;
    }

    /*
     *  Allocate a member function definition and return.
     */
    imPtr = (ItclMemberFunc*)Itcl_Alloc(sizeof(ItclMemberFunc));
    Itcl_EventuallyFree(imPtr, (Tcl_FreeProc *)Itcl_DeleteMemberFunc);
    imPtr->iclsPtr    = iclsPtr;
    imPtr->infoPtr    = iclsPtr->infoPtr;
    imPtr->protection = Itcl_Protection(interp, 0);
    imPtr->namePtr    = Tcl_NewStringObj(Tcl_GetString(namePtr), TCL_INDEX_NONE);
    Tcl_IncrRefCount(imPtr->namePtr);
    imPtr->fullNamePtr = Tcl_NewStringObj(
	    Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE);
    Tcl_AppendToObj(imPtr->fullNamePtr, "::", 2);
    Tcl_AppendToObj(imPtr->fullNamePtr, Tcl_GetString(namePtr), TCL_INDEX_NONE);
    Tcl_IncrRefCount(imPtr->fullNamePtr);
    if (arglist != NULL) {
	imPtr->origArgsPtr = Tcl_NewStringObj(arglist, TCL_INDEX_NONE);
	Tcl_IncrRefCount(imPtr->origArgsPtr);
    }
    imPtr->codePtr    = mcode;
    Itcl_PreserveData(mcode);

    if (imPtr->protection == ITCL_DEFAULT_PROTECT) {
	imPtr->protection = ITCL_PUBLIC;
    }

    imPtr->declaringClassPtr = iclsPtr;

    if (arglist) {
	imPtr->flags |= ITCL_ARG_SPEC;
    }
    if (mcode->argListPtr) {
	ItclCreateArgList(interp, arglist, &imPtr->argcount,
		&imPtr->maxargcount, &imPtr->usagePtr,
		&imPtr->argListPtr, imPtr, NULL);
	Tcl_IncrRefCount(imPtr->usagePtr);
    }

    name = Tcl_GetString(namePtr);
    if ((body != NULL) && (body[0] == '@')) {
	/* check for builtin cget isa and configure and mark them for
	 * use of a different arglist "args" for TclOO !! */
	imPtr->codePtr->flags |= ITCL_BUILTIN;
	if (strcmp(name, "cget") == 0) {
	}
	if (strcmp(name, "configure") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = TCL_INDEX_NONE;
	}
	if (strcmp(name, "isa") == 0) {
	}
	if (strcmp(name, "createhull") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "keepcomponentoption") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "ignorecomponentoption") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "renamecomponentoption") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "addoptioncomponent") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "ignoreoptioncomponent") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "renameoptioncomponent") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "setupcomponent") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "itcl_initoptions") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "mytypemethod") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	    imPtr->flags |= ITCL_COMMON;
	}
	if (strcmp(name, "mymethod") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "mytypevar") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	    imPtr->flags |= ITCL_COMMON;
	}
	if (strcmp(name, "myvar") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "itcl_hull") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	    imPtr->flags |= ITCL_COMPONENT;
	}
	if (strcmp(name, "callinstance") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "getinstancevar") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "myproc") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	    imPtr->flags |= ITCL_COMMON;
	}
	if (strcmp(name, "installhull") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "destroy") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "installcomponent") == 0) {
	    imPtr->argcount = 0;
	    imPtr->maxargcount = -1;
	}
	if (strcmp(name, "info") == 0) {
	    imPtr->flags |= ITCL_COMMON;
	}
    }
    if (strcmp(name, "constructor") == 0) {
	/*
	 * REVISE mcode->bodyPtr here!
	 * Include a [my ItclConstructBase $iclsPtr] method call.
	 * Inherited from itcl::Root
	 */

	Tcl_Obj *newBody = Tcl_NewStringObj("", TCL_INDEX_NONE);
	Tcl_AppendToObj(newBody,
		"[::info object namespace ${this}]::my ItclConstructBase ", TCL_INDEX_NONE);
	Tcl_AppendObjToObj(newBody, iclsPtr->fullNamePtr);
	Tcl_AppendToObj(newBody, "\n", TCL_INDEX_NONE);

	Tcl_AppendObjToObj(newBody, mcode->bodyPtr);
	Tcl_DecrRefCount(mcode->bodyPtr);
	mcode->bodyPtr = newBody;
	Tcl_IncrRefCount(mcode->bodyPtr);
	imPtr->flags |= ITCL_CONSTRUCTOR;
    }
    if (strcmp(name, "destructor") == 0) {
	imPtr->flags |= ITCL_DESTRUCTOR;
    }

    Tcl_SetHashValue(hPtr, imPtr);
    Itcl_PreserveData(imPtr);

    *imPtrPtr = imPtr;
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateMemberFunc()
 *
 *  Creates the data record representing a member function.  This
 *  includes the argument list and the body of the function.  If the
 *  body is of the form "@name", then it is treated as a label for
 *  a C procedure registered by Itcl_RegisterC().
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and "imPtr" returns a pointer to the new
 *  member function.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateMemberFunc(
    Tcl_Interp* interp,	    /* interpreter managing this action */
    ItclClass *iclsPtr,	    /* class definition */
    Tcl_Obj *namePtr,	      /* name of new member */
    const char* arglist,	   /* space-separated list of arg names */
    const char* body,	      /* body of commands for the method */
    ItclMemberFunc** imPtrPtr)     /* returns: pointer to new method defn */
{
    return ItclCreateMemberFunc(interp, iclsPtr, namePtr, arglist,
	    body, imPtrPtr, 0);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ChangeMemberFunc()
 *
 *  Modifies the data record representing a member function.  This
 *  is usually the body of the function, but can include the argument
 *  list if it was not defined when the member was first created.
 *  If the body is of the form "@name", then it is treated as a label
 *  for a C procedure registered by Itcl_RegisterC().
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and "imPtr" returns a pointer to the new
 *  member function.
 * ------------------------------------------------------------------------
 */
int
Itcl_ChangeMemberFunc(
    Tcl_Interp* interp,	    /* interpreter managing this action */
    ItclMemberFunc* imPtr,	 /* command member being changed */
    const char* arglist,	   /* space-separated list of arg names */
    const char* body)	      /* body of commands for the method */
{
    Tcl_HashEntry *hPtr;
    ItclMemberCode *mcode = NULL;
    int isNewEntry;

    /*
     *  Try to create the implementation for this command member.
     */
    if (ItclCreateMemberCode(interp, imPtr->iclsPtr,
	arglist, body, &mcode, imPtr->namePtr, 0) != TCL_OK) {

	return TCL_ERROR;
    }

    /*
     *  If the argument list was defined when the function was
     *  created, compare the arg lists or usage strings to make sure
     *  that the interface is not being redefined.
     */
    if ((imPtr->flags & ITCL_ARG_SPEC) != 0 &&
	    (imPtr->argListPtr != NULL) &&
	    !EquivArgLists(interp, imPtr->argListPtr, mcode->argListPtr)) {
	const char *argsStr;
	if (imPtr->origArgsPtr != NULL) {
	    argsStr = Tcl_GetString(imPtr->origArgsPtr);
	} else {
	    argsStr = "";
	}
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "argument list changed for function \"",
	    Tcl_GetString(imPtr->fullNamePtr), "\": should be \"",
	    argsStr, "\"",
	    NULL);

	Itcl_PreserveData(mcode);
	Itcl_ReleaseData(mcode);
	return TCL_ERROR;
    }

    if (imPtr->flags & ITCL_CONSTRUCTOR) {
	/*
	 * REVISE mcode->bodyPtr here!
	 * Include a [my ItclConstructBase $iclsPtr] method call.
	 * Inherited from itcl::Root
	 */

	Tcl_Obj *newBody = Tcl_NewStringObj("", TCL_INDEX_NONE);
	Tcl_AppendToObj(newBody,
		"[::info object namespace ${this}]::my ItclConstructBase ", TCL_INDEX_NONE);
	Tcl_AppendObjToObj(newBody, imPtr->iclsPtr->fullNamePtr);
	Tcl_AppendToObj(newBody, "\n", TCL_INDEX_NONE);

	Tcl_AppendObjToObj(newBody, mcode->bodyPtr);
	Tcl_DecrRefCount(mcode->bodyPtr);
	mcode->bodyPtr = newBody;
	Tcl_IncrRefCount(mcode->bodyPtr);
    }

    /*
     *  Free up the old implementation and install the new one.
     */
    Itcl_PreserveData(mcode);
    Itcl_ReleaseData(imPtr->codePtr);
    imPtr->codePtr = mcode;
    if (mcode->flags & ITCL_IMPLEMENT_TCL) {
	void *pmPtr;
	imPtr->tmPtr = Itcl_NewProcClassMethod(interp,
		imPtr->iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod,
		ItclProcErrorProc, imPtr, imPtr->namePtr, mcode->argumentPtr,
		mcode->bodyPtr, &pmPtr);
	hPtr = Tcl_CreateHashEntry(&imPtr->iclsPtr->infoPtr->procMethods,
		(char *)imPtr->tmPtr, &isNewEntry);
	if (isNewEntry) {
	    Tcl_SetHashValue(hPtr, imPtr);
	}
    }
    ItclAddClassFunctionDictInfo(interp, imPtr->iclsPtr, imPtr);
    return TCL_OK;
}

static const char * const type_reserved_words[] = {
    "type",
    "self",
    "selfns",
    NULL
};

/*
 * ------------------------------------------------------------------------
 *  ItclCreateMemberCode()
 *
 *  Creates the data record representing the implementation behind a
 *  class member function.  This includes the argument list and the body
 *  of the function.  If the body is of the form "@name", then it is
 *  treated as a label for a C procedure registered by Itcl_RegisterC().
 *
 *  The implementation is kept by the member function definition, and
 *  controlled by a preserve/release paradigm.  That way, if it is in
 *  use while it is being redefined, it will stay around long enough
 *  to avoid a core dump.
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and "mcodePtr" returns a pointer to the new
 *  implementation.
 * ------------------------------------------------------------------------
 */
static int
ItclCreateMemberCode(
    Tcl_Interp* interp,	    /* interpreter managing this action */
    ItclClass *iclsPtr,	    /* class containing this member */
    const char* arglist,	   /* space-separated list of arg names */
    const char* body,	      /* body of commands for the method */
    ItclMemberCode** mcodePtr,     /* returns: pointer to new implementation */
    Tcl_Obj *namePtr,
    int flags)
{
    Tcl_Size argc;
    Tcl_Size maxArgc;
    Tcl_Obj *usagePtr;
    ItclArgList *argListPtr;
    ItclMemberCode *mcode;
    const char *const *cPtrPtr;
    int haveError;

    /*
     *  Allocate some space to hold the implementation.
     */
    mcode = (ItclMemberCode*)Itcl_Alloc(sizeof(ItclMemberCode));
    Itcl_EventuallyFree(mcode, (Tcl_FreeProc *)FreeMemberCode);

    if (arglist) {
	if (ItclCreateArgList(interp, arglist, &argc, &maxArgc, &usagePtr,
		&argListPtr, NULL, NULL) != TCL_OK) {
	    Itcl_PreserveData(mcode);
	    Itcl_ReleaseData(mcode);
	    return TCL_ERROR;
	}
	mcode->argcount = argc;
	mcode->maxargcount = maxArgc;
	mcode->argListPtr = argListPtr;
	mcode->usagePtr = usagePtr;
	Tcl_IncrRefCount(mcode->usagePtr);
	mcode->argumentPtr = Tcl_NewStringObj((const char *)arglist, TCL_INDEX_NONE);
	Tcl_IncrRefCount(mcode->argumentPtr);
	if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) {
	    haveError = 0;
	    while (argListPtr != NULL) {
		cPtrPtr = &type_reserved_words[0];
		while (*cPtrPtr != NULL) {
		    if ((argListPtr->namePtr != NULL) &&
			    (strcmp(Tcl_GetString(argListPtr->namePtr),
			    *cPtrPtr) == 0)) {
			haveError = 1;
		    }
		    if ((flags & ITCL_COMMON) != 0) {
			if (! (iclsPtr->infoPtr->functionFlags &
				ITCL_TYPE_METHOD)) {
			    haveError = 0;
			}
		    }
		    if (haveError) {
			const char *startStr = "method ";
			if (iclsPtr->infoPtr->functionFlags &
				ITCL_TYPE_METHOD) {
			    startStr = "typemethod ";
			}
			/* FIXME should use iclsPtr->infoPtr->functionFlags here */
			if ((namePtr != NULL) &&
				(strcmp(Tcl_GetString(namePtr),
				"constructor") == 0)) {
			    startStr = "";
			}
			Tcl_AppendResult(interp, startStr,
				namePtr == NULL ? "??" :
				Tcl_GetString(namePtr),
				"'s arglist may not contain \"",
				*cPtrPtr, "\" explicitly", (char *)NULL);
			Itcl_PreserveData(mcode);
			Itcl_ReleaseData(mcode);
			return TCL_ERROR;
		    }
		    cPtrPtr++;
		}
		argListPtr = argListPtr->nextPtr;
	    }
	}
	mcode->flags   |= ITCL_ARG_SPEC;
    } else {
	argc = 0;
	argListPtr = NULL;
    }

    if (body) {
	mcode->bodyPtr = Tcl_NewStringObj((const char *)body, TCL_INDEX_NONE);
    } else {
	mcode->bodyPtr = Tcl_NewStringObj((const char *)"", TCL_INDEX_NONE);
	mcode->flags |= ITCL_IMPLEMENT_NONE;
    }
    Tcl_IncrRefCount(mcode->bodyPtr);

    /*
     *  If the body definition starts with '@', then treat the value
     *  as a symbolic name for a C procedure.
     */
    if (body == NULL) {
	/* No-op */
    } else {
	if (*body == '@') {
	    Tcl_CmdProc *argCmdProc;
	    Tcl_ObjCmdProc *objCmdProc;
	    void *cdata;
	    int isDone;

	    isDone = 0;
	    if (strcmp(body, "@itcl-builtin-cget") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-configure") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-isa") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-createhull") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-keepcomponentoption") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-ignorecomponentoption") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-renamecomponentoption") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-addoptioncomponent") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-ignoreoptioncomponent") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-renameoptioncomponent") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-setupcomponent") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-initoptions") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-mytypemethod") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-mymethod") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-myproc") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-mytypevar") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-myvar") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-itcl_hull") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-callinstance") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-getinstancevar") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-installhull") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-installcomponent") == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-destroy") == 0) {
		isDone = 1;
	    }
	    if (strncmp(body, "@itcl-builtin-setget", 20) == 0) {
		isDone = 1;
	    }
	    if (strcmp(body, "@itcl-builtin-classunknown") == 0) {
		isDone = 1;
	    }
	    if (!isDone) {
		if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc,
			&cdata)) {
		    Tcl_AppendResult(interp,
			    "no registered C procedure with name \"",
			    body+1, "\"", (char *)NULL);
		    Itcl_PreserveData(mcode);
		    Itcl_ReleaseData(mcode);
		    return TCL_ERROR;
		}

	/*
	 * WARNING! WARNING! WARNING!
	 * This is a pretty dangerous approach.  What's done here is
	 * to copy over the proc + clientData implementation that
	 * happens to be in place at the moment the method is
	 * (re-)defined.  This denies any freedom for the clientData
	 * to be changed dynamically or for the implementation to
	 * shift from OBJCMD to ARGCMD or vice versa, which the
	 * Itcl_Register(Obj)C routines explicitly permit.  The whole
	 * system also lacks any scheme to unregister.
	 */

		if (objCmdProc != NULL) {
		    mcode->flags |= ITCL_IMPLEMENT_OBJCMD;
		    mcode->cfunc.objCmd = objCmdProc;
		    mcode->clientData = cdata;
		} else {
		    if (argCmdProc != NULL) {
			mcode->flags |= ITCL_IMPLEMENT_ARGCMD;
			mcode->cfunc.argCmd = argCmdProc;
			mcode->clientData = cdata;
		    }
		}
	    } else {
		mcode->flags |= ITCL_IMPLEMENT_TCL|ITCL_BUILTIN;
	    }
	} else {

	    /*
	     *  Otherwise, treat the body as a chunk of Tcl code.
	     */
	    mcode->flags |= ITCL_IMPLEMENT_TCL;
	}
    }

    *mcodePtr = mcode;

    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateMemberCode()
 *
 *  Creates the data record representing the implementation behind a
 *  class member function.  This includes the argument list and the body
 *  of the function.  If the body is of the form "@name", then it is
 *  treated as a label for a C procedure registered by Itcl_RegisterC().
 *
 *  A member function definition holds a handle for the implementation, and
 *  uses Itcl_PreserveData and Itcl_ReleaseData to manage its interest in it.
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and stores a pointer to the new implementation in
 *  "mcodePtr".
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateMemberCode(
    Tcl_Interp* interp,	    /* interpreter managing this action */
    ItclClass *iclsPtr,	      /* class containing this member */
    const char* arglist,	   /* space-separated list of arg names */
    const char* body,	      /* body of commands for the method */
    ItclMemberCode** mcodePtr)     /* returns: pointer to new implementation */
{
    return ItclCreateMemberCode(interp, iclsPtr, arglist, body, mcodePtr,
	    NULL, 0);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteMemberCode()
 *
 *  Destroys all data associated with the given command implementation.
 *  Invoked automatically by ItclReleaseData() when the implementation
 *  is no longer being used.
 * ------------------------------------------------------------------------
 */
void FreeMemberCode (
    ItclMemberCode* mCodePtr)
{
    if (mCodePtr == NULL) {
	return;
    }
    if (mCodePtr->argListPtr != NULL) {
	ItclDeleteArgList(mCodePtr->argListPtr);
    }
    if (mCodePtr->usagePtr != NULL) {
	Tcl_DecrRefCount(mCodePtr->usagePtr);
    }
    if (mCodePtr->argumentPtr != NULL) {
	Tcl_DecrRefCount(mCodePtr->argumentPtr);
    }
    if (mCodePtr->bodyPtr != NULL) {
	Tcl_DecrRefCount(mCodePtr->bodyPtr);
    }
    Itcl_Free(mCodePtr);
}


void
Itcl_DeleteMemberCode(
    void* cdata)  /* pointer to member code definition */
{
    Itcl_ReleaseData((ItclMemberCode *)cdata);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_GetMemberCode()
 *
 *  Makes sure that the implementation for an [incr Tcl] code body is
 *  ready to run.  Note that a member function can be declared without
 *  being defined.  The class definition may contain a declaration of
 *  the member function, but its body may be defined in a separate file.
 *  If an undefined function is encountered, this routine automatically
 *  attempts to autoload it.  If the body is implemented via Tcl code,
 *  then it is compiled here as well.
 *
 *  Returns TCL_ERROR (along with an error message in the interpreter)
 *  if an error is encountered, or if the implementation is not defined
 *  and cannot be autoloaded.  Returns TCL_OK if implementation is
 *  ready to use.
 * ------------------------------------------------------------------------
 */
int
Itcl_GetMemberCode(
    Tcl_Interp* interp,	/* interpreter managing this action */
    ItclMemberFunc* imPtr)     /* member containing code body */
{
    int result;
    ItclMemberCode *mcode = imPtr->codePtr;
    assert(mcode != NULL);

    /*
     *  If the implementation has not yet been defined, try to
     *  autoload it now.
     */

    if (!Itcl_IsMemberCodeImplemented(mcode)) {
	Tcl_DString buf;

	Tcl_DStringInit(&buf);
	Tcl_DStringAppend(&buf, "::auto_load ", TCL_INDEX_NONE);
	Tcl_DStringAppend(&buf, Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE);
	result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), TCL_INDEX_NONE, 0);
	Tcl_DStringFree(&buf);
	if (result != TCL_OK) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (while autoloading code for \"%s\")",
		    Tcl_GetString(imPtr->fullNamePtr)));
	    return result;
	}
	Tcl_ResetResult(interp);  /* get rid of 1/0 status */
    }

    /*
     *  If the implementation is still not available, then
     *  autoloading must have failed.
     *
     *  TRICKY NOTE:  If code has been autoloaded, then the
     *    old mcode pointer is probably invalid.  Go back to
     *    the member and look at the current code pointer again.
     */
    mcode = imPtr->codePtr;
    assert(mcode != NULL);

    if (!Itcl_IsMemberCodeImplemented(mcode)) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "member function \"", Tcl_GetString(imPtr->fullNamePtr),
	    "\" is not defined and cannot be autoloaded",
	    (char *)NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}



static int
CallItclObjectCmd(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    Tcl_Object oPtr;
    ItclMemberFunc *imPtr = (ItclMemberFunc *)data[0];
    ItclObject *ioPtr = (ItclObject *)data[1];
    int objc = PTR2INT(data[2]);
    Tcl_Obj **objv = (Tcl_Obj **)data[3];

    ItclShowArgs(1, "CallItclObjectCmd", objc, objv);
    if (ioPtr != NULL) {
	ioPtr->hadConstructorError = 0;
    }
    if (imPtr->flags & (ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR)) {
	oPtr = ioPtr->oPtr;
    } else {
	oPtr = NULL;
    }
    if (oPtr != NULL) {
	result =  ItclObjectCmd(imPtr, interp, oPtr, imPtr->iclsPtr->clsPtr,
		objc, objv);
    } else {
	result = ItclObjectCmd(imPtr, interp, NULL, NULL, objc, objv);
    }
    if (result != TCL_OK) {
	if (ioPtr != NULL && ioPtr->hadConstructorError == 0) {
	    /* we are in a constructor call and did not yet have an error */
	    /* -1 means we are not in a constructor */
	    ioPtr->hadConstructorError = 1;
	}
    }
    return result;
}
/*
 * ------------------------------------------------------------------------
 *  Itcl_EvalMemberCode()
 *
 *  Used to execute an ItclMemberCode representation of a code
 *  fragment.  This code may be a body of Tcl commands, or a C handler
 *  procedure.
 *
 *  Executes the command with the given arguments (objc,objv) and
 *  returns an integer status code (TCL_OK/TCL_ERROR).  Returns the
 *  result string or an error message in the interpreter.
 * ------------------------------------------------------------------------
 */

int
Itcl_EvalMemberCode(
    Tcl_Interp *interp,       /* current interpreter */
    ItclMemberFunc *imPtr,    /* member func, or NULL (for error messages) */
    ItclObject *contextIoPtr,   /* object context, or NULL */
    Tcl_Size objc,		 /* number of arguments */
    Tcl_Obj *const objv[])    /* argument objects */
{
    ItclMemberCode *mcode;
    void *callbackPtr;
    int result = TCL_OK;
    Tcl_Size i;

    ItclShowArgs(1, "Itcl_EvalMemberCode", objc, objv);
    /*
     *  If this code does not have an implementation yet, then
     *  try to autoload one.  Also, if this is Tcl code, make sure
     *  that it's compiled and ready to use.
     */
    if (Itcl_GetMemberCode(interp, imPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    mcode = imPtr->codePtr;

    /*
     *  Bump the reference count on this code, in case it is
     *  redefined or deleted during execution.
     */
    Itcl_PreserveData(mcode);

    if ((imPtr->flags & ITCL_DESTRUCTOR) && (contextIoPtr != NULL)) {
	contextIoPtr->destructorHasBeenCalled = 1;
    }

    /*
     *  Execute the code body...
     */
    if (((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) ||
	    ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0)) {

	if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) {
	    result = (*mcode->cfunc.objCmd)(mcode->clientData,
		    interp, objc, objv);
	} else {
	    if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) {
		char **argv;
		argv = (char**)ckalloc(objc*sizeof(char*));
		for (i=0; i < objc; i++) {
		    argv[i] = Tcl_GetString(objv[i]);
		}

		result = (*mcode->cfunc.argCmd)(mcode->clientData,
		    interp, objc, (const char **)argv);

		ckfree((char*)argv);
	    }
	}
    } else {
	if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {
	    callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
	    Tcl_NRAddCallback(interp, CallItclObjectCmd, imPtr, contextIoPtr,
		    INT2PTR(objc), (void *)objv);
	    result = Itcl_NRRunCallbacks(interp, callbackPtr);
	 }
    }

    Itcl_ReleaseData(mcode);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclEquivArgLists()
 *
 *  Compares two argument lists to see if they are equivalent.  The
 *  first list is treated as a prototype, and the second list must
 *  match it.  Argument names may be different, but they must match in
 *  meaning.  If one argument is optional, the corresponding argument
 *  must also be optional.  If the prototype list ends with the magic
 *  "args" argument, then it matches everything in the other list.
 *
 *  Returns non-zero if the argument lists are equivalent.
 * ------------------------------------------------------------------------
 */

static int
EquivArgLists(
    TCL_UNUSED(Tcl_Interp*),
    ItclArgList *origArgs,
    ItclArgList *realArgs)
{
    ItclArgList *currPtr;
    char *argName;

    for (currPtr=origArgs; currPtr != NULL; currPtr=currPtr->nextPtr) {
	if ((realArgs != NULL) && (realArgs->namePtr == NULL)) {
	    if (currPtr->namePtr != NULL) {
		if (strcmp(Tcl_GetString(currPtr->namePtr), "args") != 0) {
		    /* the definition has more arguments */
		    return 0;
		}
	    }
	}
	if (realArgs == NULL) {
	    if (currPtr->defaultValuePtr != NULL) {
	       /* default args must be there ! */
	       return 0;
	    }
	    if (currPtr->namePtr != NULL) {
		if (strcmp(Tcl_GetString(currPtr->namePtr), "args") != 0) {
		    /* the definition has more arguments */
		    return 0;
		}
	    }
	    return 1;
	}
	if (currPtr->namePtr == NULL) {
	    /* no args defined */
	    if (realArgs->namePtr != NULL) {
		return 0;
	    }
	    return 1;
	}
	argName = Tcl_GetString(currPtr->namePtr);
	if (strcmp(argName, "args") == 0) {
	    if (currPtr->nextPtr == NULL) {
		/* this is the last arument */
		return 1;
	    }
	}
	if (currPtr->defaultValuePtr != NULL) {
	    if (realArgs->defaultValuePtr != NULL) {
		/* default values must be the same */
		if (strcmp(Tcl_GetString(currPtr->defaultValuePtr),
			Tcl_GetString(realArgs->defaultValuePtr)) != 0) {
		    return 0;
		}
	    }
	}
	realArgs = realArgs->nextPtr;
    }
    if ((currPtr == NULL) && (realArgs != NULL)) {
       /* new definition has more args then the old one */
       return 0;
    }
    return 1;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_GetContext()
 *
 *  Convenience routine for looking up the current object/class context.
 *  Useful in implementing methods/procs to see what class, and perhaps
 *  what object, is active.
 *
 *  Returns TCL_OK if the current namespace is a class namespace.
 *  Also returns pointers to the class definition, and to object
 *  data if an object context is active.  Returns TCL_ERROR (along
 *  with an error message in the interpreter) if a class namespace
 *  is not active.
 * ------------------------------------------------------------------------
 */

void
Itcl_SetContext(
    Tcl_Interp *interp,
    ItclObject *ioPtr)
{
    int isNew;
    Itcl_Stack *stackPtr;
    Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);
    ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
	    ITCL_INTERP_DATA, NULL);
    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext,
	    (char *)framePtr, &isNew);
    ItclCallContext *contextPtr
	    = (ItclCallContext *) ckalloc(sizeof(ItclCallContext));

    memset(contextPtr, 0, sizeof(ItclCallContext));
    contextPtr->ioPtr = ioPtr;
    contextPtr->refCount = 1;

    if (!isNew) {
	Tcl_Panic("frame already has context?!");
    }

    stackPtr = (Itcl_Stack *) ckalloc(sizeof(Itcl_Stack));
    Itcl_InitStack(stackPtr);
    Tcl_SetHashValue(hPtr, stackPtr);

    Itcl_PushStack(contextPtr, stackPtr);
}

void
Itcl_UnsetContext(
    Tcl_Interp *interp)
{
    Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);
    ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
	    ITCL_INTERP_DATA, NULL);
    Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext,
	    (char *)framePtr);
    Itcl_Stack *stackPtr = (Itcl_Stack *) Tcl_GetHashValue(hPtr);
    ItclCallContext *contextPtr = (ItclCallContext *)Itcl_PopStack(stackPtr);

    if (Itcl_GetStackSize(stackPtr) > 0) {
	Tcl_Panic("frame context stack not empty!");
    }
    Itcl_DeleteStack(stackPtr);
    ckfree((char *) stackPtr);
    Tcl_DeleteHashEntry(hPtr);
    if (contextPtr->refCount-- > 1) {
	Tcl_Panic("frame context ref count not zero!");
    }
    ckfree((char *)contextPtr);
}

int
Itcl_GetContext(
    Tcl_Interp *interp,	   /* current interpreter */
    ItclClass **iclsPtrPtr,       /* returns:  class definition or NULL */
    ItclObject **ioPtrPtr)	/* returns:  object data or NULL */
{
    Tcl_Namespace *nsPtr;

    /* Fetch the current call frame.  That determines context. */
    Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);

    /* Try to map it to a context stack. */
    ItclObjectInfo *infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
	    ITCL_INTERP_DATA, NULL);
    Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->frameContext,
	    (char *)framePtr);
    if (hPtr) {
	/* Frame maps to a context stack. */
	Itcl_Stack *stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
	ItclCallContext *contextPtr = (ItclCallContext *)Itcl_PeekStack(stackPtr);

	assert(contextPtr);

	if (contextPtr->objectFlags & ITCL_OBJECT_ROOT_METHOD) {
	    ItclObject *ioPtr = contextPtr->ioPtr;

	    *iclsPtrPtr = ioPtr->iclsPtr;
	    *ioPtrPtr = ioPtr;
	    return TCL_OK;
	}

	*iclsPtrPtr = contextPtr->imPtr ? contextPtr->imPtr->iclsPtr
		: contextPtr->ioPtr->iclsPtr;
	*ioPtrPtr = contextPtr->ioPtr ? contextPtr->ioPtr : infoPtr->currIoPtr;
	return TCL_OK;
    }

    /* Frame has no Itcl context data.  No way to get object context. */
    *ioPtrPtr = NULL;

    /* Fall back to namespace for possible class context info. */
    nsPtr = Tcl_GetCurrentNamespace(interp);
    hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
    if (hPtr) {
	*iclsPtrPtr = (ItclClass *)Tcl_GetHashValue(hPtr);

	/*
	 * DANGER! Following stanza of code was added to address a
	 * regression from Itcl 4.0 -> Itcl 4.1 reported in Ticket
	 * [c949e73d3e] without really understanding. May be trouble here!
	 */
	if ((*iclsPtrPtr)->nsPtr) {
	    *ioPtrPtr = (*iclsPtrPtr)->infoPtr->currIoPtr;
	}
	return TCL_OK;
    }

    /* Cannot get any context.  Record an error message. */
    if (interp) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "namespace \"%s\" is not a class namespace", nsPtr->fullName));
    }
    return TCL_ERROR;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_GetMemberFuncUsage()
 *
 *  Returns a string showing how a command member should be invoked.
 *  If the command member is a method, then the specified object name
 *  is reported as part of the invocation path:
 *
 *      obj method arg ?arg arg ...?
 *
 *  Otherwise, the "obj" pointer is ignored, and the class name is
 *  used as the invocation path:
 *
 *      class::proc arg ?arg arg ...?
 *
 *  Returns the string by appending it onto the Tcl_Obj passed in as
 *  an argument.
 * ------------------------------------------------------------------------
 */
void
Itcl_GetMemberFuncUsage(
    ItclMemberFunc *imPtr,      /* command member being examined */
    ItclObject *contextIoPtr,   /* invoked with respect to this object */
    Tcl_Obj *objPtr)	    /* returns: string showing usage */
{
    Tcl_HashEntry *entry;
    ItclMemberFunc *mf;
    ItclClass *iclsPtr;
    char *name;
    char *arglist;

    /*
     *  If the command is a method and an object context was
     *  specified, then add the object context.  If the method
     *  was a constructor, and if the object is being created,
     *  then report the invocation via the class creation command.
     */
    if ((imPtr->flags & ITCL_COMMON) == 0) {
	if ((imPtr->flags & ITCL_CONSTRUCTOR) != 0 &&
	    contextIoPtr->constructed) {

	    iclsPtr = (ItclClass*)contextIoPtr->iclsPtr;
	    mf = NULL;
	    objPtr = Tcl_NewStringObj("constructor", TCL_INDEX_NONE);
	    entry = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
	    Tcl_DecrRefCount(objPtr);
	    if (entry) {
		ItclCmdLookup *clookup;
		clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
		mf = clookup->imPtr;
	    }

	    if (mf == imPtr) {
		Tcl_GetCommandFullName(contextIoPtr->iclsPtr->interp,
		    contextIoPtr->iclsPtr->accessCmd, objPtr);
		Tcl_AppendToObj(objPtr, " ", TCL_INDEX_NONE);
		name = (char *) Tcl_GetCommandName(
		    contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd);
		Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE);
	    } else {
		Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE);
	    }
	} else {
	    if (contextIoPtr && contextIoPtr->accessCmd) {
		name = (char *) Tcl_GetCommandName(
		    contextIoPtr->iclsPtr->interp, contextIoPtr->accessCmd);
		Tcl_AppendStringsToObj(objPtr, name, " ",
			Tcl_GetString(imPtr->namePtr), (char *)NULL);
	    } else {
		Tcl_AppendStringsToObj(objPtr, "<object> ",
			Tcl_GetString(imPtr->namePtr), (char *)NULL);
	    }
	}
    } else {
	Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE);
    }

    /*
     *  Add the argument usage info.
     */
    if (imPtr->codePtr) {
	if (imPtr->codePtr->usagePtr != NULL) {
	    arglist = Tcl_GetString(imPtr->codePtr->usagePtr);
	} else {
	    arglist = NULL;
	}
    } else {
	if (imPtr->argListPtr != NULL) {
	    arglist = Tcl_GetString(imPtr->usagePtr);
	} else {
	    arglist = NULL;
	}
    }
    if (arglist) {
	if (strlen(arglist) > 0) {
	    Tcl_AppendToObj(objPtr, " ", TCL_INDEX_NONE);
	    Tcl_AppendToObj(objPtr, arglist, TCL_INDEX_NONE);
	}
    }
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ExecMethod()
 *
 *  Invoked by Tcl to handle the execution of a user-defined method.
 *  A method is similar to the usual Tcl proc, but has access to
 *  object-specific data.  If for some reason there is no current
 *  object context, then a method call is inappropriate, and an error
 *  is returned.
 *
 *  Methods are implemented either as Tcl code fragments, or as C-coded
 *  procedures.  For Tcl code fragments, command arguments are parsed
 *  according to the argument list, and the body is executed in the
 *  scope of the class where it was defined.  For C procedures, the
 *  arguments are passed in "as-is", and the procedure is executed in
 *  the most-specific class scope.
 * ------------------------------------------------------------------------
 */
static int
NRExecMethod(
    void *clientData,	/* method definition */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const *objv)    /* argument objects */
{
    ItclMemberFunc *imPtr = (ItclMemberFunc*)clientData;
    int result = TCL_OK;

    const char *token;
    Tcl_HashEntry *entry;
    ItclClass *iclsPtr;
    ItclObject *ioPtr;

    ItclShowArgs(1, "NRExecMethod", objc, objv);

    /*
     *  Make sure that the current namespace context includes an
     *  object that is being manipulated.  Methods can be executed
     *  only if an object context exists.
     */
    iclsPtr = imPtr->iclsPtr;
    if (Itcl_GetContext(interp, &iclsPtr, &ioPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (ioPtr == NULL) {
	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "cannot access object-specific info without an object context",
	    (char *)NULL);
	return TCL_ERROR;
    }

    /*
     *  Make sure that this command member can be accessed from
     *  the current namespace context.
     *  That is now done in ItclMapMethodNameProc !!
     */

    /*
     *  All methods should be "virtual" unless they are invoked with
     *  a "::" scope qualifier.
     *
     *  To implement the "virtual" behavior, find the most-specific
     *  implementation for the method by looking in the "resolveCmds"
     *  table for this class.
     */
    token = Tcl_GetString(objv[0]);
    if (strstr(token, "::") == NULL) {
	if (ioPtr != NULL) {
	    entry = Tcl_FindHashEntry(&ioPtr->iclsPtr->resolveCmds,
		(char *)imPtr->namePtr);

	    if (entry) {
		ItclCmdLookup *clookup;
		clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry);
		imPtr = clookup->imPtr;
	    }
	}
    }

    /*
     *  Execute the code for the method.  Be careful to protect
     *  the method in case it gets deleted during execution.
     */
    Itcl_PreserveData(imPtr);
    result = Itcl_EvalMemberCode(interp, imPtr, ioPtr, objc, objv);
    Itcl_ReleaseData(imPtr);
    return result;
}


int
Itcl_ExecMethod(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return Tcl_NRCallObjProc(interp, NRExecMethod, clientData, objc, objv);
}

#if TCL_MAJOR_VERSION > 8
static int
NRExecMethod2(
    void *clientData,	/* method definition */
    Tcl_Interp *interp,      /* current interpreter */
    Tcl_Size objc,	   /* number of arguments */
    Tcl_Obj *const *objv)    /* argument objects */
{
    return NRExecMethod(clientData, interp, objc, objv);
}

int
Itcl_ExecMethod2(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    return Tcl_NRCallObjProc2(interp, NRExecMethod2, clientData, objc, objv);
}
#endif /* TCL_MAJOR_VERSION */


/*
 * ------------------------------------------------------------------------
 *  Itcl_ExecProc()
 *
 *  Invoked by Tcl to handle the execution of a user-defined proc.
 *
 *  Procs are implemented either as Tcl code fragments, or as C-coded
 *  procedures.  For Tcl code fragments, command arguments are parsed
 *  according to the argument list, and the body is executed in the
 *  scope of the class where it was defined.  For C procedures, the
 *  arguments are passed in "as-is", and the procedure is executed in
 *  the most-specific class scope.
 * ------------------------------------------------------------------------
 */
static int
NRExecProc(
    void *clientData,	/* proc definition */
    Tcl_Interp *interp,      /* current interpreter */
    int objc,		/* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    ItclMemberFunc *imPtr = (ItclMemberFunc*)clientData;
    int result = TCL_OK;

    ItclShowArgs(1, "NRExecProc", objc, objv);

    /*
     *  Make sure that this command member can be accessed from
     *  the current namespace context.
     */
    if (imPtr->protection != ITCL_PUBLIC) {
	if (!Itcl_CanAccessFunc(imPtr, Tcl_GetCurrentNamespace(interp))) {
	    ItclMemberFunc *imPtr2 = NULL;
	    Tcl_HashEntry *hPtr;
	    Tcl_ObjectContext context;
	    context = (Tcl_ObjectContext)Itcl_GetCallFrameClientData(interp);
	    if (context == NULL) {
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			"can't access \"", Tcl_GetString(imPtr->fullNamePtr),
			"\": ", Itcl_ProtectionStr(imPtr->protection),
			" function", (char *)NULL);
		return TCL_ERROR;
	    }
	    hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->infoPtr->procMethods,
		    (char *)Tcl_ObjectContextMethod(context));
	    if (hPtr != NULL) {
		imPtr2 = (ItclMemberFunc *)Tcl_GetHashValue(hPtr);
	    }
	    if ((imPtr->protection & ITCL_PRIVATE) && (imPtr2 != NULL) &&
		    (imPtr->iclsPtr->nsPtr != imPtr2->iclsPtr->nsPtr)) {
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			"invalid command name \"",
			Tcl_GetString(objv[0]),
			"\"", (char *)NULL);
		return TCL_ERROR;
	    }
	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
		    "can't access \"", Tcl_GetString(imPtr->fullNamePtr),
		    "\": ", Itcl_ProtectionStr(imPtr->protection),
		    " function", (char *)NULL);
	    return TCL_ERROR;
	}
    }

    /*
     *  Execute the code for the proc.  Be careful to protect
     *  the proc in case it gets deleted during execution.
     */
    Itcl_PreserveData(imPtr);

    result = Itcl_EvalMemberCode(interp, imPtr, NULL,
	objc, objv);
    Itcl_ReleaseData(imPtr);
    return result;
}


int
Itcl_ExecProc(
    void *clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return Tcl_NRCallObjProc(interp, NRExecProc, clientData, objc, objv);
}

#if TCL_MAJOR_VERSION > 8
static int
NRExecProc2(
    void *clientData,	/* proc definition */
    Tcl_Interp *interp,      /* current interpreter */
    Tcl_Size objc,	   /* number of arguments */
    Tcl_Obj *const objv[])   /* argument objects */
{
    return NRExecProc(clientData, interp, objc, objv);
}

int
Itcl_ExecProc2(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_Size objc,
    Tcl_Obj *const *objv)
{
    return Tcl_NRCallObjProc2(interp, NRExecProc2, clientData, objc, objv);
}
#endif /* TCL_MAJOR_VERSION */

static int
CallInvokeMethodIfExists(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    ItclClass *iclsPtr = (ItclClass *)data[0];
    ItclObject *contextObj = (ItclObject *)data[1];
    int objc = PTR2INT(data[2]);
    Tcl_Obj *const *objv = (Tcl_Obj *const *)data[3];

    result = Itcl_InvokeMethodIfExists(interp, "constructor",
	    iclsPtr, contextObj, objc, (Tcl_Obj* const*)objv);

    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    return TCL_OK;
}
/*
 * ------------------------------------------------------------------------
 *  Itcl_ConstructBase()
 *
 *  Usually invoked just before executing the body of a constructor
 *  when an object is first created.  This procedure makes sure that
 *  all base classes are properly constructed.  If an "initCode" fragment
 *  was defined with the constructor for the class, then it is invoked.
 *  After that, the list of base classes is checked for constructors
 *  that are defined but have not yet been invoked.  Each of these is
 *  invoked implicitly with no arguments.
 *
 *  Assumes that a local call frame is already installed, and that
 *  constructor arguments have already been matched and are sitting in
 *  this frame.  Returns TCL_OK on success; otherwise, this procedure
 *  returns TCL_ERROR, along with an error message in the interpreter.
 * ------------------------------------------------------------------------
 */

int
Itcl_ConstructBase(
    Tcl_Interp *interp,       /* interpreter */
    ItclObject *contextObj,   /* object being constructed */
    ItclClass *contextClass)  /* current class being constructed */
{
    int result = TCL_OK;
    Tcl_Obj *objPtr;
    Itcl_ListElem *elem;

    /*
     *  If the class has an "initCode", invoke it in the current context.
     */

    if (contextClass->initCode) {

	/* TODO: NRE */
	result = Tcl_EvalObjEx(interp, contextClass->initCode, 0);
    }

    /*
     *  Scan through the list of base classes and see if any of these
     *  have not been constructed.  Invoke base class constructors
     *  implicitly, as needed.  Go through the list of base classes
     *  in reverse order, so that least-specific classes are constructed
     *  first.
     */

    objPtr = Tcl_NewStringObj("constructor", TCL_INDEX_NONE);
    Tcl_IncrRefCount(objPtr);
    for (elem = Itcl_LastListElem(&contextClass->bases);
	    result == TCL_OK && elem != NULL;
	    elem = Itcl_PrevListElem(elem)) {

	Tcl_HashEntry *entry;
	ItclClass *iclsPtr = (ItclClass*)Itcl_GetListValue(elem);

	if (Tcl_FindHashEntry(contextObj->constructed,
		(char *)iclsPtr->namePtr)) {

	    /* Already constructed, nothing to do. */
	    continue;
	}

	entry = Tcl_FindHashEntry(&iclsPtr->functions, (char *)objPtr);
	if (entry) {
	    void *callbackPtr = Itcl_GetCurrentCallbackPtr(interp);
	    Tcl_NRAddCallback(interp, CallInvokeMethodIfExists, iclsPtr,
		    contextObj, INT2PTR(0), NULL);
	    result = Itcl_NRRunCallbacks(interp, callbackPtr);
	} else {
	    result = Itcl_ConstructBase(interp, contextObj, iclsPtr);
	}
    }
    Tcl_DecrRefCount(objPtr);
    return result;
}

int
ItclConstructGuts(
    ItclObject *contextObj,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    ItclClass *contextClass;

    /* Ignore syntax error */
    if (objc != 3) {
	return TCL_OK;
    }

    /* Object is fully constructed. This becomes no-op. */
    if (contextObj->constructed == NULL) {
	return TCL_OK;
    }

    contextClass = Itcl_FindClass(interp, Tcl_GetString(objv[2]), 0);
    if (contextClass == NULL) {
	return TCL_OK;
    }


    return Itcl_ConstructBase(interp, contextObj, contextClass);
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_InvokeMethodIfExists()
 *
 *  Looks for a particular method in the specified class.  If the
 *  method is found, it is invoked with the given arguments.  Any
 *  protection level (protected/private) for the method is ignored.
 *  If the method does not exist, this procedure does nothing.
 *
 *  This procedure is used primarily to invoke the constructor/destructor
 *  when an object is created/destroyed.
 *
 *  Returns TCL_OK on success; otherwise, this procedure returns
 *  TCL_ERROR along with an error message in the interpreter.
 * ------------------------------------------------------------------------
 */
int
Itcl_InvokeMethodIfExists(
    Tcl_Interp *interp,	   /* interpreter */
    const char *name,	     /* name of desired method */
    ItclClass *contextClassPtr,   /* current class being constructed */
    ItclObject *contextObjectPtr, /* object being constructed */
    Tcl_Size objc,	       /* number of arguments */
    Tcl_Obj *const objv[])	/* argument objects */
{
    Tcl_HashEntry *hPtr;
    Tcl_Obj *cmdlinePtr;
    Tcl_Obj **cmdlinev;
    Tcl_Obj **newObjv;
    Tcl_CallFrame frame;
    ItclMemberFunc *imPtr;
    Tcl_Size cmdlinec;
    int result = TCL_OK;
    Tcl_Obj *objPtr = Tcl_NewStringObj(name, TCL_INDEX_NONE);

    ItclShowArgs(1, "Itcl_InvokeMethodIfExists", objc, objv);
    hPtr = Tcl_FindHashEntry(&contextClassPtr->functions, (char *)objPtr);
    Tcl_DecrRefCount(objPtr);
    if (hPtr) {
	imPtr  = (ItclMemberFunc*)Tcl_GetHashValue(hPtr);

	/*
	 *  Prepend the method name to the list of arguments.
	 */
	cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv);

	(void)Tcl_ListObjGetElements(NULL, cmdlinePtr,
	    &cmdlinec, &cmdlinev);

	ItclShowArgs(1, "EMC", cmdlinec, cmdlinev);
	/*
	 *  Execute the code for the method.  Be careful to protect
	 *  the method in case it gets deleted during execution.
	 */
	Itcl_PreserveData(imPtr);

	if (contextObjectPtr->oPtr == NULL) {
	    Tcl_DecrRefCount(cmdlinePtr);
	    return TCL_ERROR;
	}
	result = Itcl_EvalMemberCode(interp, imPtr, contextObjectPtr,
		cmdlinec, cmdlinev);
	Itcl_ReleaseData(imPtr);
	Tcl_DecrRefCount(cmdlinePtr);
    } else {
	if (contextClassPtr->flags &
		(ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
	    if (strcmp(name, "constructor") == 0) {
		if (objc > 0) {
		    if (contextClassPtr->numOptions == 0) {
			/* check if all options are delegeted */
			objPtr = Tcl_NewStringObj("*", TCL_INDEX_NONE);
			hPtr = Tcl_FindHashEntry(
				&contextClassPtr->delegatedOptions,
				(char *)objPtr);
			Tcl_DecrRefCount(objPtr);
			if (hPtr == NULL) {
			    Tcl_AppendResult(interp, "type \"",
				    Tcl_GetString(contextClassPtr->namePtr),
				    "\" has no options, but constructor has",
				    " option arguments", (char *)NULL);
			    return TCL_ERROR;
			}
		    }
		    if (Itcl_PushCallFrame(interp, &frame,
			    contextClassPtr->nsPtr,
			    /*isProcCallFrame*/0) != TCL_OK) {
			Tcl_AppendResult(interp, "INTERNAL ERROR in",
				"Itcl_InvokeMethodIfExists Itcl_PushCallFrame",
				(char *)NULL);
		    }
		    newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc + 2));
		    newObjv[0] = Tcl_NewStringObj("my", TCL_INDEX_NONE);
		    Tcl_IncrRefCount(newObjv[0]);
		    newObjv[1] = Tcl_NewStringObj("configure", TCL_INDEX_NONE);
		    Tcl_IncrRefCount(newObjv[1]);
		    memcpy(newObjv + 2, objv, (objc * sizeof(Tcl_Obj *)));
		    ItclShowArgs(1, "DEFAULT Constructor", objc + 2, newObjv);
		    result = Tcl_EvalObjv(interp, objc + 2, newObjv, 0);
		    Tcl_DecrRefCount(newObjv[1]);
		    Tcl_DecrRefCount(newObjv[0]);
		    ckfree((char *)newObjv);
		    Itcl_PopCallFrame(interp);
		}
	    }
	}
    }
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ReportFuncErrors()
 *
 *  Used to interpret the status code returned when the body of a
 *  Tcl-style proc is executed.  Handles the "errorInfo" and "errorCode"
 *  variables properly, and adds error information into the interpreter
 *  if anything went wrong.  Returns a new status code that should be
 *  treated as the return status code for the command.
 *
 *  This same operation is usually buried in the Tcl InterpProc()
 *  procedure.  It is defined here so that it can be reused more easily.
 * ------------------------------------------------------------------------
 */
int
Itcl_ReportFuncErrors(
    TCL_UNUSED(Tcl_Interp*),     /* interpreter being modified */
    TCL_UNUSED(ItclMemberFunc*), /* command member that was invoked */
    TCL_UNUSED(ItclObject*),     /* object context for this command */
    int result)		 /* integer status code from proc body */
{
/* FIXME !!! */
/* adapt to use of ItclProcErrorProc for stubs compatibility !! */
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_CmdAliasProc()
 *
 * ------------------------------------------------------------------------
 */
Tcl_Command
Itcl_CmdAliasProc(
    Tcl_Interp *interp,
    Tcl_Namespace *nsPtr,
    const char *cmdName,
    void *clientData)
{
    Tcl_HashEntry *hPtr;
    Tcl_Obj *objPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclObject *ioPtr;
    ItclMemberFunc *imPtr;
    ItclResolveInfo *resolveInfoPtr;
    ItclCmdLookup *clookup;

    resolveInfoPtr = (ItclResolveInfo *)clientData;
    if (resolveInfoPtr->flags & ITCL_RESOLVE_OBJECT) {
	ioPtr = resolveInfoPtr->ioPtr;
	iclsPtr = ioPtr->iclsPtr;
    } else {
	ioPtr = NULL;
	iclsPtr = resolveInfoPtr->iclsPtr;
    }
    infoPtr = iclsPtr->infoPtr;
    hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
    if (hPtr == NULL) {
	return NULL;
    }
    iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
    objPtr = Tcl_NewStringObj(cmdName, TCL_INDEX_NONE);
    hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
    Tcl_DecrRefCount(objPtr);
    if (hPtr == NULL) {
	if (strcmp(cmdName, "@itcl-builtin-cget") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::cget", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-configure") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::configure", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-destroy") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::destroy", NULL, 0);
	}
	if (strncmp(cmdName, "@itcl-builtin-setget", 20) == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::setget", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-isa") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::isa", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-createhull") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::createhull", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-keepcomponentoption") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::keepcomponentoption", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-ignorecomponentoption") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::removecomponentoption", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-irgnorecomponentoption") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::ignorecomponentoption", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-setupcomponent") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::setupcomponent", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-initoptions") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::initoptions", NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-mytypemethod") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::mytypemethod",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-mymethod") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::mymethod",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-myproc") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::myproc",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-mytypevar") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::mytypevar",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-myvar") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::myvar",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-itcl_hull") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::itcl_hull",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-callinstance") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::callinstance",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-getinstancevar") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::getinstancevar",
		    NULL, 0);
	}
	if (strcmp(cmdName, "@itcl-builtin-classunknown") == 0) {
	    return Tcl_FindCommand(interp, "::itcl::builtin::classunknown", NULL, 0);
	}
	return NULL;
    }
    clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
    imPtr = clookup->imPtr;
    return imPtr->accessCmd;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_VarAliasProc()
 *
 * ------------------------------------------------------------------------
 */
Tcl_Var
Itcl_VarAliasProc(
    TCL_UNUSED(Tcl_Interp*),
    Tcl_Namespace *nsPtr,
    const char *varName,
    void *clientData)
{

    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    ItclClass *iclsPtr;
    ItclObject *ioPtr;
    ItclVarLookup *ivlPtr;
    ItclResolveInfo *resolveInfoPtr;
    ItclCallContext *callContextPtr;
    Tcl_Var varPtr;

    varPtr = NULL;
    hPtr = NULL;
    callContextPtr = NULL;
    resolveInfoPtr = (ItclResolveInfo *)clientData;
    if (resolveInfoPtr->flags & ITCL_RESOLVE_OBJECT) {
	ioPtr = resolveInfoPtr->ioPtr;
	iclsPtr = ioPtr->iclsPtr;
    } else {
	ioPtr = NULL;
	iclsPtr = resolveInfoPtr->iclsPtr;
    }
    infoPtr = iclsPtr->infoPtr;
    hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
    if (hPtr != NULL) {
	iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
    }
    hPtr = ItclResolveVarEntry(iclsPtr, varName);
    if (hPtr == NULL) {
	/* no class/object variable */
	return NULL;
    }
    ivlPtr = (ItclVarLookup *)Tcl_GetHashValue(hPtr);
    if (ivlPtr == NULL) {
	return NULL;
    }
    if (!ivlPtr->accessible) {
	return NULL;
    }

    if (ioPtr != NULL) {
	hPtr = Tcl_FindHashEntry(&ioPtr->objectVariables,
		(char *)ivlPtr->ivPtr);
    } else {
	hPtr = Tcl_FindHashEntry(&iclsPtr->classCommons,
		(char *)ivlPtr->ivPtr);
	if (hPtr == NULL) {
	    if (callContextPtr != NULL) {
		ioPtr = callContextPtr->ioPtr;
	    }
	    if (ioPtr != NULL) {
		hPtr = Tcl_FindHashEntry(&ioPtr->objectVariables,
			(char *)ivlPtr->ivPtr);
	    }
	}
    }
    if (hPtr != NULL) {
	varPtr = (Tcl_Var)Tcl_GetHashValue(hPtr);
    }
    return varPtr;
}

/*
 * ------------------------------------------------------------------------
 *  ItclCheckCallProc()
 *
 *
 * ------------------------------------------------------------------------
 */
int
ItclCheckCallProc(
    void *clientData,
    Tcl_Interp *interp,
    TCL_UNUSED(Tcl_ObjectContext),
    TCL_UNUSED(Tcl_CallFrame*),
    int *isFinished)
{
    int result;
    ItclMemberFunc *imPtr;

    imPtr = (ItclMemberFunc *)clientData;
    if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
	Itcl_SetCallFrameResolver(interp, imPtr->iclsPtr->resolvePtr);
    }
    result = TCL_OK;

    if (isFinished != NULL) {
	*isFinished = 0;
    }
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclCheckCallMethod()
 *
 *
 * ------------------------------------------------------------------------
 */
int
ItclCheckCallMethod(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext contextPtr,
    Tcl_CallFrame *framePtr,
    int *isFinished)
{
    Itcl_Stack *stackPtr;

    Tcl_Object oPtr;
    ItclObject *ioPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *const * cObjv;
    Tcl_Namespace *currNsPtr;
    ItclCallContext *callContextPtr;
    ItclCallContext *callContextPtr2;
    ItclMemberFunc *imPtr;
    int result;
    int isNew;
    Tcl_Size cObjc;
    Tcl_Size min_allowed_args;

    ItclObjectInfo *infoPtr;

    oPtr = NULL;
    hPtr = NULL;
    imPtr = (ItclMemberFunc *)clientData;
    Itcl_PreserveData(imPtr);
    if (imPtr->flags & ITCL_CONSTRUCTOR) {
	ioPtr = imPtr->iclsPtr->infoPtr->currIoPtr;
    } else {
	if (contextPtr == NULL) {
	    if ((imPtr->flags & ITCL_COMMON) ||
		    (imPtr->codePtr->flags & ITCL_BUILTIN)) {
		if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
		    Itcl_SetCallFrameResolver(interp,
			    imPtr->iclsPtr->resolvePtr);
		}
		if (isFinished != NULL) {
		    *isFinished = 0;
		}
		return TCL_OK;
	    }
	    Tcl_AppendResult(interp,
		    "ItclCheckCallMethod cannot get context object ((char *)NULL)",
		    " for ", Tcl_GetString(imPtr->fullNamePtr),
		    NULL);
	    result = TCL_ERROR;
	    goto finishReturn;
	}
	oPtr = Tcl_ObjectContextObject(contextPtr);
	ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr,
		imPtr->iclsPtr->infoPtr->object_meta_type);
    }
    if ((imPtr->codePtr != NULL) &&
	    (imPtr->codePtr->flags & ITCL_IMPLEMENT_NONE)) {
	Tcl_AppendResult(interp, "member function \"",
		Tcl_GetString(imPtr->fullNamePtr),
		"\" is not defined and cannot be autoloaded", (char *)NULL);
	if (isFinished != NULL) {
	    *isFinished = 1;
	}
	result = TCL_ERROR;
	goto finishReturn;
    }
  if (framePtr) {
    /*
     * This stanza is in place to seize control over usage error messages
     * before TclOO examines the arguments and produces its own.  This
     * gives Itcl stability in its error messages at the cost of inconsistency
     * with Tcl's evolving conventions.
     */
    cObjc = Itcl_GetCallFrameObjc(interp);
    cObjv = Itcl_GetCallFrameObjv(interp);
    min_allowed_args = cObjc-2;
    if (strcmp(Tcl_GetString(cObjv[0]), "next") == 0) {
	min_allowed_args++;
    }
    if (min_allowed_args < imPtr->argcount) {
	Tcl_AppendResult(interp, "wrong # args: should be \"",
		Tcl_GetString(cObjv[0]), " ", Tcl_GetString(imPtr->namePtr),
		" ", Tcl_GetString(imPtr->usagePtr), "\"", (char *)NULL);
	if (isFinished != NULL) {
	    *isFinished = 1;
	}
	result = TCL_ERROR;
	goto finishReturn;
    }
  }
    isNew = 0;
    callContextPtr = NULL;
    currNsPtr = Tcl_GetCurrentNamespace(interp);
    if (ioPtr != NULL) {
	hPtr = Tcl_CreateHashEntry(&ioPtr->contextCache, (char *)imPtr, &isNew);
	if (!isNew) {
	    callContextPtr2 = (ItclCallContext *)Tcl_GetHashValue(hPtr);
	    if (callContextPtr2->refCount == 0) {
		callContextPtr = callContextPtr2;
		callContextPtr->objectFlags = ioPtr->flags;
		callContextPtr->nsPtr = Tcl_GetCurrentNamespace(interp);
		callContextPtr->ioPtr = ioPtr;
		callContextPtr->imPtr = imPtr;
		callContextPtr->refCount = 1;
	    } else {
	      if ((callContextPtr2->objectFlags == ioPtr->flags)
		    && (callContextPtr2->nsPtr == currNsPtr)) {
		callContextPtr = callContextPtr2;
		callContextPtr->refCount++;
	      }
	    }
	}
    }
    if (callContextPtr == NULL) {
	callContextPtr = (ItclCallContext *)ckalloc(
		sizeof(ItclCallContext));
	if (ioPtr == NULL) {
	    callContextPtr->objectFlags = 0;
	    callContextPtr->ioPtr = NULL;
	} else {
	    callContextPtr->objectFlags = ioPtr->flags;
	    callContextPtr->ioPtr = ioPtr;
	}
	callContextPtr->nsPtr = Tcl_GetCurrentNamespace(interp);
	callContextPtr->imPtr = imPtr;
	callContextPtr->refCount = 1;
    }
    if (isNew) {
	Tcl_SetHashValue(hPtr, callContextPtr);
    }

    if (framePtr == NULL) {
	framePtr = Itcl_GetUplevelCallFrame(interp, 0);
    }

    isNew = 0;
    infoPtr = imPtr->iclsPtr->infoPtr;
    hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext,
	    (char *)framePtr, &isNew);
    if (isNew) {
	stackPtr = (Itcl_Stack *)ckalloc(sizeof(Itcl_Stack));
	Itcl_InitStack(stackPtr);
	Tcl_SetHashValue(hPtr, stackPtr);
    } else {
	stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
    }

    assert (callContextPtr) ;
    Itcl_PushStack(callContextPtr, stackPtr);

    /* Ugly abuse alert.  Two maps in one table */
    hPtr = Tcl_CreateHashEntry(&infoPtr->frameContext,
	    (char *)contextPtr, &isNew);
    if (isNew) {
	stackPtr = (Itcl_Stack *)ckalloc(sizeof(Itcl_Stack));
	Itcl_InitStack(stackPtr);
	Tcl_SetHashValue(hPtr, stackPtr);
    } else {
	stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
    }

    Itcl_PushStack(framePtr, stackPtr);

    if (ioPtr != NULL) {
	ioPtr->callRefCount++;
	Itcl_PreserveData(ioPtr); /* ++ preserve until ItclAfterCallMethod releases it */
    }
    imPtr->iclsPtr->callRefCount++;
    if (!imPtr->iclsPtr->infoPtr->useOldResolvers) {
	Itcl_SetCallFrameResolver(interp, ioPtr->resolvePtr);
    }
    result = TCL_OK;

    if (isFinished != NULL) {
	*isFinished = 0;
    }
    return result;
finishReturn:
    Itcl_ReleaseData(imPtr);
    return result;
}

/*
 * ------------------------------------------------------------------------
 *  ItclAfterCallMethod()
 *
 *
 * ------------------------------------------------------------------------
 */
int
ItclAfterCallMethod(
    void *clientData,
    Tcl_Interp *interp,
    Tcl_ObjectContext contextPtr,
    TCL_UNUSED(Tcl_Namespace*),
    int call_result)
{
    Tcl_HashEntry *hPtr;
    ItclObject *ioPtr;
    ItclMemberFunc *imPtr;
    ItclCallContext *callContextPtr;
    int newEntry;
    int result;

    imPtr = (ItclMemberFunc *)clientData;
    callContextPtr = NULL;
    if (contextPtr != NULL) {
    ItclObjectInfo *infoPtr = imPtr->infoPtr;
    Tcl_CallFrame *framePtr;
    Itcl_Stack *stackPtr;

    hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)contextPtr);
    assert(hPtr);
    stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
    framePtr = (Tcl_CallFrame *)Itcl_PopStack(stackPtr);
    if (Itcl_GetStackSize(stackPtr) == 0) {
	Itcl_DeleteStack(stackPtr);
	ckfree((char *) stackPtr);
	Tcl_DeleteHashEntry(hPtr);
    }

    hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr);
    assert(hPtr);
    stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
    callContextPtr = (ItclCallContext *)Itcl_PopStack(stackPtr);
    if (Itcl_GetStackSize(stackPtr) == 0) {
	Itcl_DeleteStack(stackPtr);
	ckfree((char *) stackPtr);
	Tcl_DeleteHashEntry(hPtr);
    }
    }
    if (callContextPtr == NULL) {
	if ((imPtr->flags & ITCL_COMMON) ||
		(imPtr->codePtr->flags & ITCL_BUILTIN)) {
	    result = call_result;
	    goto finishReturn;
	}
	Tcl_AppendResult(interp,
		"ItclAfterCallMethod cannot get context object ((char *)NULL)",
		" for ", Tcl_GetString(imPtr->fullNamePtr), NULL);
	result = TCL_ERROR;
	goto finishReturn;
    }
    /*
     *  If this is a constructor or destructor, and if it is being
     *  invoked at the appropriate time, keep track of which methods
     *  have been called.  This information is used to implicitly
     *  invoke constructors/destructors as needed.
     */
    ioPtr = callContextPtr->ioPtr;
    if (ioPtr != NULL) {
      if (imPtr->iclsPtr) {
	imPtr->iclsPtr->callRefCount--;
	if (imPtr->flags & (ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR)) {
	    if ((imPtr->flags & ITCL_DESTRUCTOR) && ioPtr &&
		 ioPtr->destructed) {
		Tcl_CreateHashEntry(ioPtr->destructed,
		    (char *)imPtr->iclsPtr->namePtr, &newEntry);
	    }
	    if ((imPtr->flags & ITCL_CONSTRUCTOR) && ioPtr &&
		 ioPtr->constructed) {
		Tcl_CreateHashEntry(ioPtr->constructed,
		    (char *)imPtr->iclsPtr->namePtr, &newEntry);
	    }
	}
      }
	ioPtr->callRefCount--;
	if (ioPtr->flags & ITCL_OBJECT_SHOULD_VARNS_DELETE) {
	    ItclDeleteObjectVariablesNamespace(interp, ioPtr);
	}
    }

    if (callContextPtr->refCount-- <= 1) {
	if (callContextPtr->ioPtr != NULL) {
	    hPtr = Tcl_FindHashEntry(&callContextPtr->ioPtr->contextCache,
		    (char *)callContextPtr->imPtr);
	    if (hPtr == NULL) {
		ckfree((char *)callContextPtr);
	    }
	} else {
	    ckfree((char *)callContextPtr);
	}
    }

    if (ioPtr != NULL) {
	Itcl_ReleaseData(ioPtr); /* -- paired release for preserve in ItclCheckCallMethod */
    }
    result = call_result;
finishReturn:
    Itcl_ReleaseData(imPtr);
    return result;
}

void
ItclProcErrorProc(
    Tcl_Interp *interp,
    TCL_UNUSED(Tcl_Obj*))
{
    Tcl_Obj *objPtr;
    Tcl_HashEntry *hPtr;
    ItclObjectInfo *infoPtr;
    ItclCallContext *callContextPtr;
    ItclMemberFunc *imPtr;
    ItclObject *contextIoPtr;
    ItclClass *currIclsPtr;
    char num[20];
    Itcl_Stack *stackPtr;

    /* Fetch the current call frame.  That determines context. */
    Tcl_CallFrame *framePtr = Itcl_GetUplevelCallFrame(interp, 0);

    /* Try to map it to a context stack. */
    infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
	    ITCL_INTERP_DATA, NULL);
    hPtr = Tcl_FindHashEntry(&infoPtr->frameContext, (char *)framePtr);
    if (hPtr == NULL) {
	/* Can this happen? */
	return;
    }

    /* Frame maps to a context stack. */
    stackPtr = (Itcl_Stack *)Tcl_GetHashValue(hPtr);
    callContextPtr = (ItclCallContext *)Itcl_PeekStack(stackPtr);

    if (callContextPtr == NULL) {
	return;
    }

    currIclsPtr = NULL;
    objPtr = NULL;
    {
	imPtr = callContextPtr->imPtr;
	contextIoPtr = callContextPtr->ioPtr;
	objPtr = Tcl_NewStringObj("\n    ", TCL_INDEX_NONE);

	if (imPtr->flags & ITCL_CONSTRUCTOR) {
	    currIclsPtr = imPtr->iclsPtr;
	    Tcl_AppendToObj(objPtr, "while constructing object \"", TCL_INDEX_NONE);
	    Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
	    Tcl_AppendToObj(objPtr, "\" in ", TCL_INDEX_NONE);
	    Tcl_AppendToObj(objPtr, currIclsPtr->nsPtr->fullName, TCL_INDEX_NONE);
	    Tcl_AppendToObj(objPtr, "::constructor", TCL_INDEX_NONE);
	    if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) {
		Tcl_AppendToObj(objPtr, " (", TCL_INDEX_NONE);
	    }
	}
	if (imPtr->flags & ITCL_DESTRUCTOR) {
	    contextIoPtr->flags = 0;
	    Tcl_AppendToObj(objPtr, "while deleting object \"", TCL_INDEX_NONE);
	    Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
	    Tcl_AppendToObj(objPtr, "\" in ", TCL_INDEX_NONE);
	    Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE);
	    if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) {
		Tcl_AppendToObj(objPtr, " (", TCL_INDEX_NONE);
	    }
	}
	if (!(imPtr->flags & (ITCL_CONSTRUCTOR|ITCL_DESTRUCTOR))) {
	    Tcl_AppendToObj(objPtr, "(", TCL_INDEX_NONE);

	    hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)contextIoPtr);
	    if (hPtr != NULL) {
	      if ((contextIoPtr != NULL) && (contextIoPtr->accessCmd)) {
		Tcl_AppendToObj(objPtr, "object \"", TCL_INDEX_NONE);
		Tcl_GetCommandFullName(interp, contextIoPtr->accessCmd, objPtr);
		Tcl_AppendToObj(objPtr, "\" ", TCL_INDEX_NONE);
	      }
	    }

	    if ((imPtr->flags & ITCL_COMMON) != 0) {
		Tcl_AppendToObj(objPtr, "procedure", TCL_INDEX_NONE);
	    } else {
		Tcl_AppendToObj(objPtr, "method", TCL_INDEX_NONE);
	    }
	    Tcl_AppendToObj(objPtr, " \"", TCL_INDEX_NONE);
	    Tcl_AppendToObj(objPtr, Tcl_GetString(imPtr->fullNamePtr), TCL_INDEX_NONE);
	    Tcl_AppendToObj(objPtr, "\" ", TCL_INDEX_NONE);
	}

	if ((imPtr->codePtr->flags & ITCL_IMPLEMENT_TCL) != 0) {
	    Tcl_Obj *dictPtr;
	    Tcl_Obj *keyPtr;
	    Tcl_Obj *valuePtr;
	    int lineNo;

	    keyPtr = Tcl_NewStringObj("-errorline", TCL_INDEX_NONE);
	    dictPtr = Tcl_GetReturnOptions(interp, TCL_ERROR);
	    if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) {
		/* how should we handle an error ? */
		Tcl_DecrRefCount(dictPtr);
		Tcl_DecrRefCount(keyPtr);
		Tcl_DecrRefCount(objPtr);
		return;
	    }
	    if (valuePtr == NULL) {
		/* how should we handle an error ? */
		Tcl_DecrRefCount(dictPtr);
		Tcl_DecrRefCount(keyPtr);
		Tcl_DecrRefCount(objPtr);
		return;
	    }
	    if (Tcl_GetIntFromObj(interp, valuePtr, &lineNo) != TCL_OK) {
		/* how should we handle an error ? */
		Tcl_DecrRefCount(dictPtr);
		Tcl_DecrRefCount(keyPtr);
		Tcl_DecrRefCount(objPtr);
		return;
	    }
	    Tcl_DecrRefCount(dictPtr);
	    Tcl_DecrRefCount(keyPtr);
	    Tcl_AppendToObj(objPtr, "body line ", TCL_INDEX_NONE);
	    sprintf(num, "%d", lineNo);
	    Tcl_AppendToObj(objPtr, num, TCL_INDEX_NONE);
	    Tcl_AppendToObj(objPtr, ")", TCL_INDEX_NONE);
	} else {
	    Tcl_AppendToObj(objPtr, ")", TCL_INDEX_NONE);
	}

	Tcl_AppendObjToErrorInfo(interp, objPtr);
	objPtr = NULL;
    }
    if (objPtr != NULL) {
	Tcl_DecrRefCount(objPtr);
    }
}