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
|
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
|
-
+
+
+
+
+
+
+
|
/*
* tclOOMethod.c --
*
* 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.1.2.9 2008/09/02 17:52:43 dgp Exp $
* RCS: @(#) $Id: tclOOMethod.c,v 1.1.2.10 2008/09/23 13:50:54 dgp Exp $
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
#if 0
#define DBPRINT(format, ...) (fprintf(stderr, "DEBUG:" format "\n", __VA_ARGS__))
#else
#define DBPRINT(format, ...) ((void) 0)
#endif
/*
* Structure used to help delay computing names of objects or classes for
* [info frame] until needed, making invokation faster in the normal case.
*/
struct PNI {
Tcl_Interp *interp; /* Interpreter in which to compute the name of
|
| ︙ | | |
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
Tcl_Obj *nameObj; /* The "name" of the command. */
Command cmd; /* The command structure. Mostly bogus. */
ExtraFrameInfo efi; /* Extra information used for [info frame]. */
struct PNI pni; /* Specialist information used in the efi
* field for this type of call. */
} PMFrameData;
/*
* Structure used to pass information about variable resolution to the
* on-the-ground resolvers used when working with resolved compiled variables.
*/
typedef struct {
Tcl_ResolvedVarInfo info; /* "Type" information so that the compiled
* variable can be linked to the namespace
* variable at the right time. */
Tcl_Obj *variableObj; /* The name of the variable. */
Tcl_Var cachedObjectVar; /* TODO: When to flush this cache? Can class
* variables be cached? */
} OOResVarInfo;
/*
* Function declarations for things defined in this file.
*/
static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv, int toRewrite,
int rewriteLength, Tcl_Obj *const *rewriteObjs,
|
| ︙ | | |
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
|
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
static Tcl_Obj * RenderDeclarerName(ClientData clientData);
static int InvokeForwardMethod(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static void DeleteForwardMethod(ClientData clientData);
static int CloneForwardMethod(Tcl_Interp *interp,
ClientData clientData, ClientData *newClientData);
static int ProcedureMethodVarResolver(Tcl_Interp *interp,
const char *varName, Tcl_Namespace *contextNs,
int flags, Tcl_Var *varPtr);
static int ProcedureMethodCompiledVarResolver(Tcl_Interp *interp,
const char *varName, int length,
Tcl_Namespace *contextNs,
Tcl_ResolvedVarInfo **rPtrPtr);
/*
* The types of methods defined by the core OO system.
*/
static const Tcl_MethodType procMethodType = {
TCL_OO_METHOD_VERSION_CURRENT, "procedural method",
InvokeProcedureMethod, DeleteProcedureMethod, CloneProcedureMethod
};
static const Tcl_MethodType fwdMethodType = {
TCL_OO_METHOD_VERSION_CURRENT, "forward",
InvokeForwardMethod, DeleteForwardMethod, CloneForwardMethod
};
/*
* Helper macros (derived from things private to tclVar.c)
*/
#define TclVarTable(contextNs) \
((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable))
#define TclVarHashGetValue(hPtr) \
((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry)))
/*
* ----------------------------------------------------------------------
*
* Tcl_NewInstanceMethod --
*
* Attach a method to an object instance.
|
| ︙ | | |
315
316
317
318
319
320
321
322
323
324
325
326
327
328
|
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
|
+
|
return NULL;
}
pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (method == NULL) {
ckfree((char *) pmPtr);
} else if (pmPtrPtr != NULL) {
*pmPtrPtr = pmPtr;
}
|
| ︙ | | |
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
|
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
|
-
-
+
+
-
|
pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj,
procName, argsObj, bodyObj, &procMethodType, pmPtr,
method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
&pmPtr->procPtr);
|
| ︙ | | |
862
863
864
865
866
867
868
869
870
871
872
873
874
875
|
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOSetupVariableResolver, etc. --
*
* Variable resolution engine used to connect declared variables to local
* variables used in methods. The compiled variable resolver is more
* important, but both are needed as it is possible to have a variable
* that is only referred to in ways that aren't compilable and we can't
* force LVT presence. [TIP #320]
*
* ----------------------------------------------------------------------
*/
void
TclOOSetupVariableResolver(
Tcl_Namespace *nsPtr)
{
Tcl_ResolverInfo info;
Tcl_GetNamespaceResolvers(nsPtr, &info);
if (info.compiledVarResProc == NULL) {
Tcl_SetNamespaceResolvers(nsPtr, NULL, ProcedureMethodVarResolver,
ProcedureMethodCompiledVarResolver);
}
}
static int
ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
int flags,
Tcl_Var *varPtr)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
Tcl_HashEntry *hPtr;
int i, isNew;
/*
* Check that the variable is being requested in a context that is also a
* method call; if not (i.e. we're evaluating in the object's namespace or
* in a procedure of that namespace) then we do nothing.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return TCL_CONTINUE;
}
contextPtr = framePtr->clientData;
/*
* Check if the variable is one we want to resolve at all (i.e. whether it
* is in the list provided by the user). If not, we mustn't do anything
* either.
*/
if (contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr != NULL) {
FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr->variables) {
if (!strcmp(Tcl_GetString(variableObj), varName)) {
goto gotMatch;
}
}
} else {
FOREACH(variableObj, contextPtr->oPtr->variables) {
if (!strcmp(Tcl_GetString(variableObj), varName)) {
goto gotMatch;
}
}
}
return TCL_CONTINUE;
/*
* It is a variable we want to resolve, so resolve it.
*/
gotMatch:
hPtr = Tcl_CreateHashEntry(TclVarTable(contextNs), (char *) variableObj,
&isNew);
if (isNew) {
TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
}
*varPtr = TclVarHashGetValue(hPtr);
return TCL_OK;
}
static Tcl_Var
ProcedureMethodCompiledVarConnect(
Tcl_Interp *interp,
Tcl_ResolvedVarInfo *rPtr)
{
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
Tcl_HashEntry *hPtr;
int i, isNew, cacheIt;
const char *varName = Tcl_GetString(infoPtr->variableObj);
/*
* Check that the variable is being requested in a context that is also a
* method call; if not (i.e. we're evaluating in the object's namespace or
* in a procedure of that namespace) then we do nothing.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return NULL;
}
contextPtr = framePtr->clientData;
/*
* If we've done the work before (in a comparable context) then reuse that
* rather than performing resolution ourselves.
*/
if (infoPtr->cachedObjectVar) {
return infoPtr->cachedObjectVar;
}
/*
* Check if the variable is one we want to resolve at all (i.e. whether it
* is in the list provided by the user). If not, we mustn't do anything
* either.
*/
if (contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr != NULL) {
FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
.mPtr->declaringClassPtr->variables) {
if (!strcmp(Tcl_GetString(variableObj), varName)) {
cacheIt = 0;
goto gotMatch;
}
}
} else {
FOREACH(variableObj, contextPtr->oPtr->variables) {
if (!strcmp(Tcl_GetString(variableObj), varName)) {
cacheIt = 1;
goto gotMatch;
}
}
}
return NULL;
/*
* It is a variable we want to resolve, so resolve it.
*/
gotMatch:
hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr),
(char *) variableObj, &isNew);
if (isNew) {
TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr));
}
if (cacheIt) {
infoPtr->cachedObjectVar = TclVarHashGetValue(hPtr);
}
return TclVarHashGetValue(hPtr);
}
static void
ProcedureMethodCompiledVarDelete(
Tcl_ResolvedVarInfo *rPtr)
{
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
Tcl_DecrRefCount(infoPtr->variableObj);
ckfree((char *) infoPtr);
}
static int
ProcedureMethodCompiledVarResolver(
Tcl_Interp *interp,
const char *varName,
int length,
Tcl_Namespace *contextNs,
Tcl_ResolvedVarInfo **rPtrPtr)
{
OOResVarInfo *infoPtr;
Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
/*
* Do not create resolvers for cases that contain namespace separators or
* which look like array accesses. Both will lead us astray.
*/
if (strstr(Tcl_GetString(variableObj), "::") != NULL ||
Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) {
Tcl_DecrRefCount(variableObj);
return TCL_CONTINUE;
}
infoPtr = (OOResVarInfo *) ckalloc(sizeof(OOResVarInfo));
infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
infoPtr->cachedObjectVar = NULL;
infoPtr->variableObj = variableObj;
Tcl_IncrRefCount(variableObj);
*rPtrPtr = &infoPtr->info;
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* RenderDeclarerName --
*
* Returns the name of the entity (object or class) which declared a
* method. Used for producing information for [info frame] in such a way
* that the expensive part of this (generating the object or class name
* itself) isn't done until it is needed.
*
|
| ︙ | | |
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
|
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = mPtr->clientData;
return pmPtr->procPtr;
}
return NULL;
}
Tcl_Obj *
TclOOGetMethodBody(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = mPtr->clientData;
if (pmPtr->procPtr->bodyPtr->bytes == NULL) {
(void) Tcl_GetString(pmPtr->procPtr->bodyPtr);
}
return pmPtr->procPtr->bodyPtr;
}
return NULL;
}
Tcl_Obj *
TclOOGetFwdFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &fwdMethodType) {
ForwardMethod *fwPtr = mPtr->clientData;
|
| ︙ | | |