Tcl Source Code

Check-in [a8d83acd18]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:NRE-aware TclOO.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | potential incompatibility
Files: files | file ages | folders
SHA1: a8d83acd188df8a873518f5d731cf8cea8f0c668
User & Date: dkf 2008-07-16 22:08:59
Context
2008-07-16
23:31
* win/tclWinThrd.c: Test for TLS_OUT_OF_INDEXES to make certain that thread key creation is successf... check-in: fc0e0a02ad user: georgeps tags: trunk
22:08
NRE-aware TclOO. check-in: a8d83acd18 user: dkf tags: trunk, potential incompatibility
00:44
* tests/NRE.test: better constraint for testing the * tests/stack.test: existence of teststack...
check-in: 41e62e1505 user: msofer tags: trunk
Changes
Hide Diffs Unified Diffs Show Whitespace Changes Patch

Changes to ChangeLog.













1
2
3
4

5
6
7
8
9
10
11
12
13
14
15
..
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32











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
>
>
>
>
>
>
>
>
>
>
>
>


|
<
>
|
|
|
|







 







|
|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20
21
22
23
24
25
26
27
..
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
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

Changes to generic/tclOO.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
66
67
68
69
70
71
72




73
74
75
76
77
78
79
80
81
82
83



84
85
86



87
88
89
90
91
92
93
...
472
473
474
475
476
477
478

479
480
481
482
483
484
485
...
490
491
492
493
494
495
496

497
498
499
500
501
502
503
...
554
555
556
557
558
559
560
561

562
563
564
565
566
567
568
....
1239
1240
1241
1242
1243
1244
1245
1246

1247
1248
1249
1250
1251
1252
1253
....
1774
1775
1776
1777
1778
1779
1780










1781
1782
1783
1784
1785
1786
1787










1788
1789
1790
1791
1792
1793
1794
....
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916











1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935

1936
1937
1938
1939
1940
1941
1942
....
1983
1984
1985
1986
1987
1988
1989
1990

1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001






































































2002
2003
2004
2005
2006
2007
2008
 *	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.






|







 







>
>
>
>











>
>
>



>
>
>







 







>







 







>







 







|
>







 







|
>







 







>
>
>
>
>
>
>
>
>
>







>
>
>
>
>
>
>
>
>
>







 







|
|









|
>
>
>
>
>
>
>
>
>
>
>





<








|



|
>







 







|
>











>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
...
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
...
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
...
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
....
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
....
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
....
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966

1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
....
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
 *	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.

Changes to generic/tclOOBasic.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19



20
21
22
23
24
25
26
...
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
...
597
598
599
600
601
602
603

604
605










606
607
608
609
610
611
612
613
 *	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 --






|







>
>
>







 







<







 







>

|
>
>
>
>
>
>
>
>
>
>
|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
...
580
581
582
583
584
585
586

587
588
589
590
591
592
593
...
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
 *	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 --

Changes to generic/tclOOCall.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
62
63
64
65
66
67
68


69
70
71




72
73
74
75
76
77
78
...
227
228
229
230
231
232
233

234
235
236
237
238
239
240
241
242

243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
...
263
264
265
266
267
268
269








270
271
272
273
274
275
276




277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294

295






296
297











298

299
300








301
302
303
304
305
306
307
308
309
310
311
312
 *	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;
}
 
/*
 * ----------------------------------------------------------------------
 *






|







 







>
>



>
>
>
>







 







>
|



<
<
|
|

>

<


<







|







 







>
>
>
>
>
>
>
>






|
>
>
>
>










|

|
<
<
<
<

>
|
>
>
>
>
>
>
|
<
>
>
>
>
>
>
>
>
>
>
>
|
>
|
<
>
>
>
>
>
>
>
>




<







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
...
233
234
235
236
237
238
239
240
241
242
243
244


245
246
247
248
249

250
251

252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
...
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305




306
307
308
309
310
311
312
313
314
315

316
317
318
319
320
321
322
323
324
325
326
327
328
329

330
331
332
333
334
335
336
337
338
339
340
341

342
343
344
345
346
347
348
 *	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;
}
 
/*
 * ----------------------------------------------------------------------
 *

Changes to generic/tclOOInt.h.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
489
490
491
492
493
494
495
496
497
498



499
500
501
502
503
504
505
 *	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,






|







 







|
|
|
>
>
>







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
 *	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,

Changes to generic/tclOOMethod.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
51
52
53
54
55
56
57


58
59
60
61
62
63
64
...
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655

656

657
658
659
660
661
662
663
...
664
665
666
667
668
669
670
671




672
673
674
675
676
677
678
679
680
681

682
683











684
685
686
687
688
689
690
...
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
....
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
 *	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;
}
 
/*
 * ----------------------------------------------------------------------
 *






|







 







>
>







 







<









<








|
>

>







 







|
>
>
>
>




|
<
<


<
>
|
|
>
>
>
>
>
>
>
>
>
>
>







 







<







 







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
..
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
...
631
632
633
634
635
636
637

638
639
640
641
642
643
644
645
646

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
...
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682


683
684

685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
...
710
711
712
713
714
715
716

717
718
719
720
721
722
723
....
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
 *	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;
}
 
/*
 * ----------------------------------------------------------------------
 *