Tcl Source Code

2008-07-15  Miguel Sofer  <[email protected]>

	* tests/NRE.test:    better constraint for testing the 
	* tests/stack.test:  existence of teststacklimit, to insure that

	                     the testsuite runs under tclsh.
	
	* generic/tclParse.c: fixing incomplete reversion of "fix" for
	[Bug 2017583], missing TclResetCancellation call. 

2008-07-15  Donal K. Fellows  <[email protected]>

	* generic/tclBasic.c (Tcl_CancelEval): Fix blunder. [Bug 2018603]

	* doc/DictObj.3: Fix error in example. [Bug 2016740]

................................................................................
	* generic/tclNamesp.c (EnsembleUnknownCallback): Factor out some of
	the more complex parts of the ensemble code to make it easier to
	understand and hence to permit tighter compilation of code on the
	critical path.

2008-07-14  Miguel Sofer  <[email protected]>

	* generic/tclParse.c: reverting the "fix" for [Bug 2017583],
	* tests/parse.test:   numLevel management and TclInterpReady check
	                      seems to be necessary after all.
	
2008-07-14  Donal K. Fellows  <[email protected]>

	* generic/tclProc.c (TclNRApplyObjCmd, TclObjInterpProcCore): 
	* generic/tclBasic.c (TclNR_AddCallback, TclEvalObjv_NR2): 
	* generic/tclNRE.h (TEOV_callback): Change the callback storage type
	to use an array, so guaranteeing correct inter-member spacing and

2008-07-16  Donal K. Fellows  <[email protected]>

	* generic/tclOO.c, generic/tclOOInt.h, generic/tclOOBasic.c:
	* generic/tclOOCall.c, generic/tclOOMethod.c: NRE-enable the TclOO
	implementation in Tcl. No change to public APIs, except that method
	implementations can now be NRE-aware if they choose (which normal
	methods and forwards are). On the other hand, callers of
	TclOOInvokeObject (which is only in the internal stub table) will need
	to deal with the fact that it's only safe to call inside an NRE-aware
	context.
	***POTENTIAL INCOMPATIBILITY***

2008-07-15  Miguel Sofer  <[email protected]>

	* tests/NRE.test:    Better constraint for testing the existence of

	* tests/stack.test:  teststacklimit, to insure that the test suite
	                     runs under tclsh.

	* generic/tclParse.c: fixing incomplete reversion of "fix" for [Bug
	2017583], missing TclResetCancellation call.

2008-07-15  Donal K. Fellows  <[email protected]>

	* generic/tclBasic.c (Tcl_CancelEval): Fix blunder. [Bug 2018603]

	* doc/DictObj.3: Fix error in example. [Bug 2016740]

................................................................................
	* generic/tclNamesp.c (EnsembleUnknownCallback): Factor out some of
	the more complex parts of the ensemble code to make it easier to
	understand and hence to permit tighter compilation of code on the
	critical path.

2008-07-14  Miguel Sofer  <[email protected]>

	* generic/tclParse.c: Reverting the "fix" for [Bug 2017583], numLevel
	* tests/parse.test:   management and TclInterpReady check seems to be
	                      necessary after all.

2008-07-14  Donal K. Fellows  <[email protected]>

	* generic/tclProc.c (TclNRApplyObjCmd, TclObjInterpProcCore):
	* generic/tclBasic.c (TclNR_AddCallback, TclEvalObjv_NR2):
	* generic/tclNRE.h (TEOV_callback): Change the callback storage type
	to use an array, so guaranteeing correct inter-member spacing and

 *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOO.c,v 1.9 2008/06/19 21:29:03 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr,
			    const char *nsNameStr);
static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
			    Method *mPtr, Tcl_Obj *namePtr,
			    Method **newMPtrPtr);
static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
			    Method *mPtr, Tcl_Obj *namePtr);




static void		InitFoundation(Tcl_Interp *interp);
static void		KillFoundation(ClientData clientData,
			    Tcl_Interp *interp);
static void		ObjectNamespaceDeleted(ClientData clientData);
static void		ObjectRenamedTrace(ClientData clientData,
			    Tcl_Interp *interp, const char *oldName,
			    const char *newName, int flags);
static void		ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);

static int		PublicObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,



			    Tcl_Obj *const *objv);
static int		PrivateObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,



			    Tcl_Obj *const *objv);

/*
 * Methods in the oo::object and oo::class classes. First, we define a helper
 * macro that makes building the method type declaration structure a lot
 * easier. No point in making life harder than it has to be!
 *
................................................................................
	    oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
		    PublicObjectCmd, oPtr, NULL);
	}
    } else {
	oPtr->command = Tcl_CreateObjCommand(interp,
		oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
    }


    /*
     * Access the namespace command table directly when creating "my" to avoid
     * a bottleneck in string manipulation.
     */

    {
................................................................................
	cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
		&creationEpoch /*ignored*/ );
	cmdPtr->refCount = 1;
	cmdPtr->objProc = PrivateObjectCmd;
	cmdPtr->objClientData = oPtr;
	cmdPtr->proc = TclInvokeObjectCommand;
	cmdPtr->clientData = cmdPtr;

	Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
    }

    Tcl_TraceCommand(interp, TclGetString(TclOOObjectName(interp, oPtr)),
	    TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, oPtr);

    return oPtr;
................................................................................
	if (contextPtr != NULL) {
	    int result;
	    Tcl_InterpState state;

	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = TclOOInvokeContext(interp, contextPtr, 0, NULL);

	    if (result != TCL_OK) {
		Tcl_BackgroundError(interp);
	    }
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }
................................................................................
	    int result;
	    Tcl_InterpState state;

	    AddRef(oPtr);
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;
	    result = TclOOInvokeContext(interp, contextPtr, objc, objv);

	    TclOODeleteContext(contextPtr);
	    DelRef(oPtr);
	    if (result != TCL_OK) {
		Tcl_DiscardInterpState(state);
		Tcl_DeleteCommandFromToken(interp, oPtr->command);
		return NULL;
	    }
................................................................................

static int
PublicObjectCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)










{
    return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD,
	    NULL);
}

static int
PrivateObjectCmd(










    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
}
................................................................................
		break;
	    }
	}
	if (contextPtr->index >= contextPtr->callPtr->numChain) {
	    result = TCL_ERROR;
	    Tcl_SetResult(interp, "no valid method implementation",
		    TCL_STATIC);
	    AddRef(oPtr);		/* Just to balance. */
	    goto disposeChain;
	}
    }

    /*
     * Invoke the call chain, locking the object structure against deletion
     * for the duration.
     */

    AddRef(oPtr);
    result = TclOOInvokeContext(interp, contextPtr, objc, objv);












    /*
     * Dispose of the call chain and drop the lock on the object's structure.
     */

  disposeChain:
    TclOODeleteContext(contextPtr);
    DelRef(oPtr);
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * Tcl_ObjectContextInvokeNext --
 *
 *	Invokes the next stage of the call chain described in an object
 *	context. This is the core of the implementation of the [next] command.
 *	Does not do management of the call-frame stack.

 *
 * ----------------------------------------------------------------------
 */

int
Tcl_ObjectContextInvokeNext(
    Tcl_Interp *interp,
................................................................................
    contextPtr->index++;
    contextPtr->skip = skip;

    /*
     * Invoke the (advanced) method call context in the caller context.
     */

    result = TclOOInvokeContext(interp, contextPtr, objc, objv);


    /*
     * Restore the call chain context index as we've finished the inner invoke
     * and want to operate in the outer context again.
     */

    contextPtr->index = savedIndex;
    contextPtr->skip = savedSkip;

    return result;
}






































































 
/*
 * ----------------------------------------------------------------------
 *
 * Tcl_GetObjectFromObj --
 *
 *	Utility function to get an object from a Tcl_Obj containing its name.

 *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOO.c,v 1.10 2008/07/16 22:09:00 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
static Object *		AllocObject(Tcl_Interp *interp, const char *nameStr,
			    const char *nsNameStr);
static int		CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
			    Method *mPtr, Tcl_Obj *namePtr,
			    Method **newMPtrPtr);
static int		CloneObjectMethod(Tcl_Interp *interp, Object *oPtr,
			    Method *mPtr, Tcl_Obj *namePtr);
static int		FinalizeNext(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		FinalizeObjectCall(ClientData data[],
			    Tcl_Interp *interp, int result);
static void		InitFoundation(Tcl_Interp *interp);
static void		KillFoundation(ClientData clientData,
			    Tcl_Interp *interp);
static void		ObjectNamespaceDeleted(ClientData clientData);
static void		ObjectRenamedTrace(ClientData clientData,
			    Tcl_Interp *interp, const char *oldName,
			    const char *newName, int flags);
static void		ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);

static int		PublicObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static int		PublicNRObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static int		PrivateObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);
static int		PrivateNRObjectCmd(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv);

/*
 * Methods in the oo::object and oo::class classes. First, we define a helper
 * macro that makes building the method type declaration structure a lot
 * easier. No point in making life harder than it has to be!
 *
................................................................................
	    oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
		    PublicObjectCmd, oPtr, NULL);
	}
    } else {
	oPtr->command = Tcl_CreateObjCommand(interp,
		oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
    }
    ((Command *) oPtr->command)->nreProc = PublicNRObjectCmd;

    /*
     * Access the namespace command table directly when creating "my" to avoid
     * a bottleneck in string manipulation.
     */

    {
................................................................................
	cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
		&creationEpoch /*ignored*/ );
	cmdPtr->refCount = 1;
	cmdPtr->objProc = PrivateObjectCmd;
	cmdPtr->objClientData = oPtr;
	cmdPtr->proc = TclInvokeObjectCommand;
	cmdPtr->clientData = cmdPtr;
	cmdPtr->nreProc = PrivateNRObjectCmd;
	Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
    }

    Tcl_TraceCommand(interp, TclGetString(TclOOObjectName(interp, oPtr)),
	    TCL_TRACE_RENAME|TCL_TRACE_DELETE, ObjectRenamedTrace, oPtr);

    return oPtr;
................................................................................
	if (contextPtr != NULL) {
	    int result;
	    Tcl_InterpState state;

	    contextPtr->callPtr->flags |= DESTRUCTOR;
	    contextPtr->skip = 0;
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    result = TclNR_CallObjProc(interp, TclOOInvokeContext, contextPtr,
		    0, NULL);
	    if (result != TCL_OK) {
		Tcl_BackgroundError(interp);
	    }
	    Tcl_RestoreInterpState(interp, state);
	    TclOODeleteContext(contextPtr);
	}
    }
................................................................................
	    int result;
	    Tcl_InterpState state;

	    AddRef(oPtr);
	    state = Tcl_SaveInterpState(interp, TCL_OK);
	    contextPtr->callPtr->flags |= CONSTRUCTOR;
	    contextPtr->skip = skip;
	    result = TclNR_CallObjProc(interp, TclOOInvokeContext, contextPtr,
		    objc, objv);
	    TclOODeleteContext(contextPtr);
	    DelRef(oPtr);
	    if (result != TCL_OK) {
		Tcl_DiscardInterpState(state);
		Tcl_DeleteCommandFromToken(interp, oPtr->command);
		return NULL;
	    }
................................................................................

static int
PublicObjectCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return TclNR_CallObjProc(interp, PublicNRObjectCmd, clientData,objc,objv);
}

static int
PublicNRObjectCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return TclOOObjectCmdCore(clientData, interp, objc, objv, PUBLIC_METHOD,
	    NULL);
}

static int
PrivateObjectCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return TclNR_CallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
}

static int
PrivateNRObjectCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    return TclOOObjectCmdCore(clientData, interp, objc, objv, 0, NULL);
}
................................................................................
		break;
	    }
	}
	if (contextPtr->index >= contextPtr->callPtr->numChain) {
	    result = TCL_ERROR;
	    Tcl_SetResult(interp, "no valid method implementation",
		    TCL_STATIC);
	    TclOODeleteContext(contextPtr);
	    return TCL_ERROR;
	}
    }

    /*
     * Invoke the call chain, locking the object structure against deletion
     * for the duration.
     */

    AddRef(oPtr);
    TclNR_AddCallback(interp, FinalizeObjectCall, contextPtr,oPtr, NULL,NULL);
    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

static int
FinalizeObjectCall(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    register CallContext *contextPtr = data[0];
    register Object *oPtr = data[1];

    /*
     * Dispose of the call chain and drop the lock on the object's structure.
     */


    TclOODeleteContext(contextPtr);
    DelRef(oPtr);
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext --
 *
 *	Invokes the next stage of the call chain described in an object
 *	context. This is the core of the implementation of the [next] command.
 *	Does not do management of the call-frame stack. Available in public
 *	(standard API) and private (NRE-aware) forms.
 *
 * ----------------------------------------------------------------------
 */

int
Tcl_ObjectContextInvokeNext(
    Tcl_Interp *interp,
................................................................................
    contextPtr->index++;
    contextPtr->skip = skip;

    /*
     * Invoke the (advanced) method call context in the caller context.
     */

    result = TclNR_CallObjProc(interp, TclOOInvokeContext, contextPtr, objc,
	    objv);

    /*
     * Restore the call chain context index as we've finished the inner invoke
     * and want to operate in the outer context again.
     */

    contextPtr->index = savedIndex;
    contextPtr->skip = savedSkip;

    return result;
}

int
TclNRObjectContextInvokeNext(
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv,
    int skip)
{
    register CallContext *contextPtr = (CallContext *) context;

    if (contextPtr->index+1 >= contextPtr->callPtr->numChain) {
	/*
	 * We're at the end of the chain; generate an error message.
	 */

	const char *methodType;

	if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	    methodType = "constructor";
	} else if (contextPtr->callPtr->flags & DESTRUCTOR) {
	    methodType = "destructor";
	} else {
	    methodType = "method";
	}

	Tcl_AppendResult(interp, "no next ", methodType, " implementation",
		NULL);
	return TCL_ERROR;
    }

    /*
     * Advance to the next method implementation in the chain in the method
     * call context while we process the body. However, need to adjust the
     * argument-skip control because we're guaranteed to have a single prefix
     * arg (i.e., 'next') and not the variable amount that can happen because
     * method invokations (i.e., '$obj meth' and 'my meth'), constructors
     * (i.e., '$cls new' and '$cls create obj') and destructors (no args at
     * all) come through the same code.
     */

    TclNR_AddCallback(interp, FinalizeNext, contextPtr,
	    INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL);
    contextPtr->index++;
    contextPtr->skip = skip;

    /*
     * Invoke the (advanced) method call context in the caller context.
     */

    return TclOOInvokeContext(contextPtr, interp, objc, objv);
}

static int
FinalizeNext(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];

    /*
     * Restore the call chain context index as we've finished the inner invoke
     * and want to operate in the outer context again.
     */

    contextPtr->index = PTR2INT(data[1]);
    contextPtr->skip = PTR2INT(data[2]);
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * Tcl_GetObjectFromObj --
 *
 *	Utility function to get an object from a Tcl_Obj containing its name.

 *	methods from the object-system core.
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOBasic.c,v 1.1 2008/05/31 11:42:17 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"



 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --
 *
 *	Implementation for oo::class->create method.
................................................................................
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    Tcl_ObjectContext context;
    int result;

    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

................................................................................
    context = framePtr->clientData;

    /*
     * Invoke the (advanced) method call context in the caller context. Note
     * that this is like [uplevel 1] and not [eval].
     */


    iPtr->varFramePtr = framePtr->callerVarPtr;
    result = Tcl_ObjectContextInvokeNext(interp, context, objc, objv, 1);










    iPtr->varFramePtr = framePtr;
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOSelfObjCmd --

 *	methods from the object-system core.
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOBasic.c,v 1.2 2008/07/16 22:09:01 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

static int		RestoreFrame(ClientData data[],
			    Tcl_Interp *interp, int result);
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOO_Class_Create --
 *
 *	Implementation for oo::class->create method.
................................................................................
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *framePtr = iPtr->varFramePtr;
    Tcl_ObjectContext context;


    /*
     * Start with sanity checks on the calling context to make sure that we
     * are invoked from a suitable method context. If so, we can safely
     * retrieve the handle to the object call context.
     */

................................................................................
    context = framePtr->clientData;

    /*
     * Invoke the (advanced) method call context in the caller context. Note
     * that this is like [uplevel 1] and not [eval].
     */

    TclNR_AddCallback(interp, RestoreFrame, framePtr, NULL, NULL, NULL);
    iPtr->varFramePtr = framePtr->callerVarPtr;
    return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}

static int
RestoreFrame(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    Interp *iPtr = (Interp *) interp;

    iPtr->varFramePtr = data[0];
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *
 * TclOOSelfObjCmd --

 *	object-system core.
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOCall.c,v 1.7 2008/06/19 20:57:23 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
static void		AddSimpleClassChainToCallContext(Class *classPtr,
			    Tcl_Obj *const methodNameObj,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static int		CmpStr(const void *ptr1, const void *ptr2);
static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);


static void		FreeMethodNameRep(Tcl_Obj *objPtr);
static inline int	IsStillValid(CallChain *callPtr, Object *oPtr,
			    int flags, int reuseMask);




static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);

/*
 * Object type used to manage type caches attached to method names.
 */

static Tcl_ObjType methodNameType = {
................................................................................
 *	in stack usage as possible.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOInvokeContext(

    Tcl_Interp *const interp,	/* Interpreter for error reporting, and many
				 * other sorts of context handling (e.g.,
				 * commands, variables) depending on method
				 * implementation. */
    CallContext *const contextPtr,
				/* The method call context. */
    const int objc,		/* The number of arguments. */
    Tcl_Obj *const *const objv)	/* The arguments as actually seen. */
{

    Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    const int isFirst = (contextPtr->index == 0);
    const int isFilter =
	    contextPtr->callPtr->chain[contextPtr->index].isFilter;
    int result, wasFilter;

    /*
     * If this is the first step along the chain, we preserve the method
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (isFirst) {
	int i;

	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
................................................................................
	 * Ensure that the method name itself is part of the arguments when
	 * we're doing unknown processing.
	 */

	if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) {
	    contextPtr->skip--;
	}








    }

    /*
     * Save whether we were in a filter and set up whether we are now.
     */

    wasFilter = contextPtr->oPtr->flags & FILTER_HANDLING;




    if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
	contextPtr->oPtr->flags |= FILTER_HANDLING;
    } else {
	contextPtr->oPtr->flags &= ~FILTER_HANDLING;
    }

    /*
     * Run the method implementation.
     */

    result = mPtr->typePtr->callProc(mPtr->clientData, interp,
	    (Tcl_ObjectContext) contextPtr, objc, objv);

    /*
     * Restore the old filter-ness, release any locks on method
     * implementations, and return the result code.
     */


    if (wasFilter) {






	contextPtr->oPtr->flags |= FILTER_HANDLING;
    } else {











	contextPtr->oPtr->flags &= ~FILTER_HANDLING;

    }
    if (isFirst) {








	int i;

	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	    TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
	}
    }
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *

 *	object-system core.
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOCall.c,v 1.8 2008/07/16 22:09:02 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
static void		AddSimpleClassChainToCallContext(Class *classPtr,
			    Tcl_Obj *const methodNameObj,
			    struct ChainBuilder *const cbPtr,
			    Tcl_HashTable *const doneFilters, int flags,
			    Class *const filterDecl);
static int		CmpStr(const void *ptr1, const void *ptr2);
static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
static int		FinalizeMethodRefs(ClientData data[],
			    Tcl_Interp *interp, int result);
static void		FreeMethodNameRep(Tcl_Obj *objPtr);
static inline int	IsStillValid(CallChain *callPtr, Object *oPtr,
			    int flags, int reuseMask);
static int		ResetFilterFlags(ClientData data[],
			    Tcl_Interp *interp, int result);
static int		SetFilterFlags(ClientData data[],
			    Tcl_Interp *interp, int result);
static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);

/*
 * Object type used to manage type caches attached to method names.
 */

static Tcl_ObjType methodNameType = {
................................................................................
 *	in stack usage as possible.
 *
 * ----------------------------------------------------------------------
 */

int
TclOOInvokeContext(
    ClientData clientData,	/* The method call context. */
    Tcl_Interp *interp,		/* Interpreter for error reporting, and many
				 * other sorts of context handling (e.g.,
				 * commands, variables) depending on method
				 * implementation. */


    int objc,			/* The number of arguments. */
    Tcl_Obj *const objv[])	/* The arguments as actually seen. */
{
    register CallContext *const contextPtr = clientData;
    Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;

    const int isFilter =
	    contextPtr->callPtr->chain[contextPtr->index].isFilter;


    /*
     * If this is the first step along the chain, we preserve the method
     * entries in the chain so that they do not get deleted out from under our
     * feet.
     */

    if (contextPtr->index == 0) {
	int i;

	for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	    AddRef(contextPtr->callPtr->chain[i].mPtr);
	}

	/*
................................................................................
	 * Ensure that the method name itself is part of the arguments when
	 * we're doing unknown processing.
	 */

	if (contextPtr->callPtr->flags & OO_UNKNOWN_METHOD) {
	    contextPtr->skip--;
	}

	/*
	 * Add a callback to ensure that method references are dropped once
	 * this call is finished.
	 */

	TclNR_AddCallback(interp, FinalizeMethodRefs, contextPtr, NULL, NULL,
		NULL);
    }

    /*
     * Save whether we were in a filter and set up whether we are now.
     */

    if (contextPtr->oPtr->flags & FILTER_HANDLING) {
	TclNR_AddCallback(interp, SetFilterFlags, contextPtr, NULL,NULL,NULL);
    } else {
	TclNR_AddCallback(interp, ResetFilterFlags,contextPtr,NULL,NULL,NULL);
    }
    if (isFilter || contextPtr->callPtr->flags & FILTER_HANDLING) {
	contextPtr->oPtr->flags |= FILTER_HANDLING;
    } else {
	contextPtr->oPtr->flags &= ~FILTER_HANDLING;
    }

    /*
     * Run the method implementation.
     */

    return mPtr->typePtr->callProc(mPtr->clientData, interp,
	    (Tcl_ObjectContext) contextPtr, objc, objv);
}





static int
SetFilterFlags(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];

    contextPtr->oPtr->flags |= FILTER_HANDLING;

    return result;
}

static int
ResetFilterFlags(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];

    contextPtr->oPtr->flags &= ~FILTER_HANDLING;
    return result;
}


static int
FinalizeMethodRefs(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    CallContext *contextPtr = data[0];
    int i;

    for (i=0 ; i<contextPtr->callPtr->numChain ; i++) {
	TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);

    }
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *

 *	declarations for the object-system (NB: not Tcl_Obj, but ::oo).
 *
 * Copyright (c) 2006 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOInt.h,v 1.2 2008/05/31 19:56:07 dkf Exp $
 */

#include <tclInt.h>
#include "tclOO.h"

/*
 * Forward declarations.
................................................................................
MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE int	TclOOGetSortedClassMethodList(Class *clsPtr,
			    int flags, const char ***stringsPtr);
MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,
			    const char ***stringsPtr);
MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int	TclOOInvokeContext(Tcl_Interp *const interp,
			    CallContext *const contextPtr, int const objc,
			    Tcl_Obj *const *const objv);



MODULE_SCOPE void	TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
			    const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,
			    Class *mixinPtr);
MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,

 *	declarations for the object-system (NB: not Tcl_Obj, but ::oo).
 *
 * Copyright (c) 2006 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOInt.h,v 1.3 2008/07/16 22:09:02 dkf Exp $
 */

#include <tclInt.h>
#include "tclOO.h"

/*
 * Forward declarations.
................................................................................
MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE int	TclOOGetSortedClassMethodList(Class *clsPtr,
			    int flags, const char ***stringsPtr);
MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,
			    const char ***stringsPtr);
MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int	TclOOInvokeContext(ClientData clientData,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
			    Tcl_ObjectContext context, int objc,
			    Tcl_Obj *const *objv, int skip);
MODULE_SCOPE void	TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
			    const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,
			    Class *mixinPtr);
MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,

 *	This file contains code to create and manage methods.
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOMethod.c,v 1.5 2008/06/01 08:11:07 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
static Tcl_Obj **	InitEnsembleRewrite(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv, int toRewrite,
			    int rewriteLength, Tcl_Obj *const *rewriteObjs,
			    int *lengthPtr);
static int		InvokeProcedureMethod(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);


static int		PushMethodCallFrame(Tcl_Interp *interp,
			    CallContext *contextPtr, ProcedureMethod *pmPtr,
			    int objc, Tcl_Obj *const *objv,
			    PMFrameData *fdPtr);
static void		DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
static void		DeleteProcedureMethod(ClientData clientData);
static int		CloneProcedureMethod(Tcl_Interp *interp,
................................................................................
    Tcl_Interp *interp,
    Tcl_ObjectContext context,	/* The method calling context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
{
    ProcedureMethod *pmPtr = clientData;
    int result;
    register int skip;
    PMFrameData *fdPtr;		/* Important data that has to have a lifetime
				 * matched by this function (or rather, by the
				 * call frame's lifetime). */

    /*
     * Allocate the special frame data.
     */

    fdPtr = (PMFrameData *) TclStackAlloc(interp, sizeof(PMFrameData));
    pmPtr->refCount++;

    /*
     * Create a call frame for this method.
     */

    result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
	    objc, objv, fdPtr);
    if (result != TCL_OK) {
	goto done;

    }


    /*
     * Give the pre-call callback a chance to do some setup and, possibly,
     * veto the call.
     */

    if (pmPtr->preCallProc != NULL) {
................................................................................
	int isFinished;

	result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
		(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
	if (isFinished || result != TCL_OK) {
	    Tcl_PopCallFrame(interp);
	    TclStackFree(interp, fdPtr->framePtr);
	    goto done;




	}
    }

    /*
     * Now invoke the body of the method. Note that we need to take special
     * action when doing unknown processing to ensure that the missing method
     * name is passed as an argument.
     */

    skip = Tcl_ObjectContextSkippedArgs(context);

    result = TclObjInterpProcCore(interp, fdPtr->nameObj, skip,
	    fdPtr->errProc);












    /*
     * Give the post-call callback a chance to do some cleanup. Note that at
     * this point the call frame itself is invalid; it's already been popped.
     */

    if (pmPtr->postCallProc) {
................................................................................

    /*
     * Scrap the special frame data now that we're done with it. Note that we
     * are inlining DeleteProcedureMethod() here; this location is highly
     * sensitive when it comes to performance!
     */

  done:
    if (--pmPtr->refCount < 1) {
	DeleteProcedureMethodRecord(pmPtr);
    }
    TclStackFree(interp, fdPtr);
    return result;
}

................................................................................
     * can ignore here.
     */

    Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
    argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
	    numPrefixes, prefixObjs, &len);

    result = Tcl_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
    TclStackFree(interp, argObjs);
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *

 *	This file contains code to create and manage methods.
 *
 * Copyright (c) 2005-2008 by Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclOOMethod.c,v 1.6 2008/07/16 22:09:02 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
static Tcl_Obj **	InitEnsembleRewrite(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const *objv, int toRewrite,
			    int rewriteLength, Tcl_Obj *const *rewriteObjs,
			    int *lengthPtr);
static int		InvokeProcedureMethod(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		FinalizePMCall(ClientData data[], Tcl_Interp *interp,
			    int result);
static int		PushMethodCallFrame(Tcl_Interp *interp,
			    CallContext *contextPtr, ProcedureMethod *pmPtr,
			    int objc, Tcl_Obj *const *objv,
			    PMFrameData *fdPtr);
static void		DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
static void		DeleteProcedureMethod(ClientData clientData);
static int		CloneProcedureMethod(Tcl_Interp *interp,
................................................................................
    Tcl_Interp *interp,
    Tcl_ObjectContext context,	/* The method calling context. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const *objv)	/* Arguments as actually seen. */
{
    ProcedureMethod *pmPtr = clientData;
    int result;

    PMFrameData *fdPtr;		/* Important data that has to have a lifetime
				 * matched by this function (or rather, by the
				 * call frame's lifetime). */

    /*
     * Allocate the special frame data.
     */

    fdPtr = (PMFrameData *) TclStackAlloc(interp, sizeof(PMFrameData));


    /*
     * Create a call frame for this method.
     */

    result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
	    objc, objv, fdPtr);
    if (result != TCL_OK) {
	TclStackFree(interp, fdPtr);
	return result;
    }
    pmPtr->refCount++;

    /*
     * Give the pre-call callback a chance to do some setup and, possibly,
     * veto the call.
     */

    if (pmPtr->preCallProc != NULL) {
................................................................................
	int isFinished;

	result = pmPtr->preCallProc(pmPtr->clientData, interp, context,
		(Tcl_CallFrame *) fdPtr->framePtr, &isFinished);
	if (isFinished || result != TCL_OK) {
	    Tcl_PopCallFrame(interp);
	    TclStackFree(interp, fdPtr->framePtr);
	    if (--pmPtr->refCount < 1) {
		DeleteProcedureMethodRecord(pmPtr);
	    }
	    TclStackFree(interp, fdPtr);
	    return result;
	}
    }

    /*
     * Now invoke the body of the method.


     */


    TclNR_AddCallback(interp, FinalizePMCall, pmPtr, context, fdPtr, NULL);
    return TclNRInterpProcCore(interp, fdPtr->nameObj,
	    Tcl_ObjectContextSkippedArgs(context), fdPtr->errProc);
}

static int
FinalizePMCall(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    ProcedureMethod *pmPtr = data[0];
    Tcl_ObjectContext context = data[1];
    PMFrameData *fdPtr = data[2];

    /*
     * Give the post-call callback a chance to do some cleanup. Note that at
     * this point the call frame itself is invalid; it's already been popped.
     */

    if (pmPtr->postCallProc) {
................................................................................

    /*
     * Scrap the special frame data now that we're done with it. Note that we
     * are inlining DeleteProcedureMethod() here; this location is highly
     * sensitive when it comes to performance!
     */


    if (--pmPtr->refCount < 1) {
	DeleteProcedureMethodRecord(pmPtr);
    }
    TclStackFree(interp, fdPtr);
    return result;
}

................................................................................
     * can ignore here.
     */

    Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
    argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
	    numPrefixes, prefixObjs, &len);

    result = TclNR_EvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE);
    TclStackFree(interp, argObjs);
    return result;
}
 
/*
 * ----------------------------------------------------------------------
 *