summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c175
1 files changed, 63 insertions, 112 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 8c65de3..613225c 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -67,7 +67,7 @@ const Tcl_ObjType tclProcBodyType = {
* should panic instead. */
};
-#define ProcSetInternalRep(objPtr, procPtr) \
+#define ProcSetIntRep(objPtr, procPtr) \
do { \
Tcl_ObjInternalRep ir; \
(procPtr)->refCount++; \
@@ -76,7 +76,7 @@ const Tcl_ObjType tclProcBodyType = {
Tcl_StoreInternalRep((objPtr), &tclProcBodyType, &ir); \
} while (0)
-#define ProcGetInternalRep(objPtr, procPtr) \
+#define ProcGetIntRep(objPtr, procPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &tclProcBodyType); \
@@ -84,7 +84,7 @@ const Tcl_ObjType tclProcBodyType = {
} while (0)
/*
- * The [upvar]/[uplevel] level reference type. Uses the longValue field
+ * The [upvar]/[uplevel] level reference type. Uses the wideValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
@@ -113,7 +113,7 @@ static const Tcl_ObjType lambdaType = {
SetLambdaFromAny /* setFromAnyProc */
};
-#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \
+#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \
do { \
Tcl_ObjInternalRep ir; \
ir.twoPtrValue.ptr1 = (procPtr); \
@@ -122,7 +122,7 @@ static const Tcl_ObjType lambdaType = {
Tcl_StoreInternalRep((objPtr), &lambdaType, &ir); \
} while (0)
-#define LambdaGetInternalRep(objPtr, procPtr, nsObjPtr) \
+#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
do { \
const Tcl_ObjInternalRep *irPtr; \
irPtr = TclFetchInternalRep((objPtr), &lambdaType); \
@@ -150,7 +150,7 @@ static const Tcl_ObjType lambdaType = {
int
Tcl_ProcObjCmd(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -261,11 +261,11 @@ Tcl_ProcObjCmd(
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
- CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
+ CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame));
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *)ckalloc(sizeof(int));
+ cfPtr->line = (int *)Tcl_Alloc(sizeof(int));
cfPtr->line[0] = contextPtr->line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -293,9 +293,9 @@ Tcl_ProcObjCmd(
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
- ckfree(cfOldPtr->line);
+ Tcl_Free(cfOldPtr->line);
cfOldPtr->line = NULL;
- ckfree(cfOldPtr);
+ Tcl_Free(cfOldPtr);
}
Tcl_SetHashValue(hePtr, cfPtr);
}
@@ -327,7 +327,7 @@ Tcl_ProcObjCmd(
* of all procs whose argument list is just _args_
*/
- if (TclHasInternalRep(objv[3], &tclProcBodyType)) {
+ if (objv[3]->typePtr == &tclProcBodyType) {
goto done;
}
@@ -338,7 +338,7 @@ Tcl_ProcObjCmd(
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
- int numBytes;
+ size_t numBytes;
procArgs +=4;
while (*procArgs != '\0') {
@@ -352,7 +352,7 @@ Tcl_ProcObjCmd(
* The argument list is just "args"; check the body
*/
- procBody = TclGetStringFromObj(objv[3], &numBytes);
+ procBody = Tcl_GetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
@@ -409,7 +409,7 @@ TclCreateProc(
Tcl_Obj **argArray;
int precompiled = 0;
- ProcGetInternalRep(bodyPtr, procPtr);
+ ProcGetIntRep(bodyPtr, procPtr);
if (procPtr != NULL) {
/*
* Because the body is a TclProProcBody, the actual body is already
@@ -444,10 +444,10 @@ TclCreateProc(
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
- int length;
+ size_t length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
- bytes = TclGetStringFromObj(bodyPtr, &length);
+ bytes = Tcl_GetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
/*
@@ -467,7 +467,7 @@ TclCreateProc(
Tcl_IncrRefCount(bodyPtr);
- procPtr = (Proc *)ckalloc(sizeof(Proc));
+ procPtr = (Proc *)Tcl_Alloc(sizeof(Proc));
procPtr->iPtr = iPtr;
procPtr->refCount = 1;
procPtr->bodyPtr = bodyPtr;
@@ -507,7 +507,8 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
const char *argname, *argnamei, *argnamelast;
- int fieldCount, nameLength;
+ int fieldCount;
+ size_t nameLength;
Tcl_Obj **fieldValues;
/*
@@ -529,7 +530,7 @@ TclCreateProc(
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- if ((fieldCount == 0) || (TclGetCharLength(fieldValues[0]) == 0)) {
+ if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
@@ -550,7 +551,7 @@ TclCreateProc(
if (*argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
- Tcl_GetString(fieldValues[0])));
+ TclGetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
@@ -599,10 +600,9 @@ TclCreateProc(
*/
if (localPtr->defValuePtr != NULL) {
- const char *tmpPtr = TclGetString(localPtr->defValuePtr);
- size_t tmpLength = localPtr->defValuePtr->length;
- const char *value = TclGetString(fieldValues[1]);
- size_t valueLength = fieldValues[1]->length;
+ size_t tmpLength, valueLength;
+ const char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, &tmpLength);
+ const char *value = Tcl_GetStringFromObj(fieldValues[1], &valueLength);
if ((valueLength != tmpLength)
|| memcmp(value, tmpPtr, tmpLength) != 0
@@ -632,7 +632,7 @@ TclCreateProc(
* local variables for the argument.
*/
- localPtr = (CompiledLocal *)ckalloc(
+ localPtr = (CompiledLocal *)Tcl_Alloc(
offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
@@ -678,9 +678,9 @@ TclCreateProc(
Tcl_DecrRefCount(localPtr->defValuePtr);
}
- ckfree(localPtr);
+ Tcl_Free(localPtr);
}
- ckfree(procPtr);
+ Tcl_Free(procPtr);
}
return TCL_ERROR;
}
@@ -896,7 +896,7 @@ Tcl_UplevelObjCmd(
int
TclNRUplevelObjCmd(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -1079,11 +1079,7 @@ ProcWrongNumArgs(
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
} else {
-#ifdef AVOID_HACKS_FOR_ITCL
desiredObjs[0] = framePtr->objv[skip-1];
-#else
- desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1);
-#endif /* AVOID_HACKS_FOR_ITCL */
}
Tcl_IncrRefCount(desiredObjs[0]);
@@ -1122,54 +1118,6 @@ ProcWrongNumArgs(
/*
*----------------------------------------------------------------------
*
- * TclInitCompiledLocals --
- *
- * This routine is invoked in order to initialize the compiled locals
- * table for a new call frame.
- *
- * DEPRECATED: functionality has been inlined elsewhere; this function
- * remains to insure binary compatibility with Itcl.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May invoke various name resolvers in order to determine which
- * variables are being referenced at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclInitCompiledLocals(
- Tcl_Interp *interp, /* Current interpreter. */
- CallFrame *framePtr, /* Call frame to initialize. */
- Namespace *nsPtr) /* Pointer to current namespace. */
-{
- Var *varPtr = framePtr->compiledLocals;
- Tcl_Obj *bodyPtr;
- ByteCode *codePtr;
-
- bodyPtr = framePtr->procPtr->bodyPtr;
- ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr);
- if (codePtr == NULL) {
- Tcl_Panic("body object for proc attached to frame is not a byte code type");
- }
-
- if (framePtr->numCompiledLocals) {
- if (!codePtr->localCachePtr) {
- InitLocalCache(framePtr->procPtr) ;
- }
- framePtr->localCachePtr = codePtr->localCachePtr;
- framePtr->localCachePtr->refCount++;
- }
-
- InitResolvedLocals(interp, codePtr, varPtr, nsPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
* InitResolvedLocals --
*
* This routine is invoked in order to initialize the compiled locals
@@ -1223,7 +1171,7 @@ InitResolvedLocals(
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
- ckfree(localPtr->resolveInfo);
+ Tcl_Free(localPtr->resolveInfo);
}
localPtr->resolveInfo = NULL;
}
@@ -1309,7 +1257,7 @@ TclFreeLocalCache(
TclReleaseLiteral(interp, objPtr);
}
}
- ckfree(localCachePtr);
+ Tcl_Free(localCachePtr);
}
static void
@@ -1335,7 +1283,7 @@ InitLocalCache(
* for future calls.
*/
- localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0)
+ localCachePtr = (LocalCache *)Tcl_Alloc(offsetof(LocalCache, varName0)
+ localCt * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
@@ -1347,7 +1295,7 @@ InitLocalCache(
*namePtr = NULL;
} else {
*namePtr = TclCreateLiteral(iPtr, localPtr->name,
- localPtr->nameLength, /* hash */ (unsigned int) -1,
+ localPtr->nameLength, /* hash */ -1,
&isNew, /* nsPtr */ NULL, 0, NULL);
Tcl_IncrRefCount(*namePtr);
}
@@ -1701,7 +1649,7 @@ TclNRInterpProcCore(
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
- int skip, /* Number of initial arguments to be skipped,
+ size_t skip1, /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
ProcErrorProc *errorProc) /* How to convert results from the script into
* results of the overall procedure. */
@@ -1711,6 +1659,7 @@ TclNRInterpProcCore(
int result;
CallFrame *freePtr;
ByteCode *codePtr;
+ int skip = skip1;
result = InitArgsAndLocals(interp, skip);
if (result != TCL_OK) {
@@ -2020,10 +1969,10 @@ TclProcCompileProc(
if (toFree->resolveInfo->deleteProc) {
toFree->resolveInfo->deleteProc(toFree->resolveInfo);
} else {
- ckfree(toFree->resolveInfo);
+ Tcl_Free(toFree->resolveInfo);
}
}
- ckfree(toFree);
+ Tcl_Free(toFree);
}
procPtr->numCompiledLocals = procPtr->numArgs;
}
@@ -2084,13 +2033,14 @@ MakeProcError(
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
- int overflow, limit = 60, nameLen;
- const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
+ unsigned int overflow, limit = 60;
+ size_t nameLen;
+ const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %d)",
- (overflow ? limit : nameLen), procName,
+ (int)(overflow ? limit :nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
@@ -2165,7 +2115,7 @@ TclProcCleanupProc(
if (resVarInfo->deleteProc) {
resVarInfo->deleteProc(resVarInfo);
} else {
- ckfree(resVarInfo);
+ Tcl_Free(resVarInfo);
}
}
@@ -2173,10 +2123,10 @@ TclProcCleanupProc(
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
- ckfree(localPtr);
+ Tcl_Free(localPtr);
localPtr = nextPtr;
}
- ckfree(procPtr);
+ Tcl_Free(procPtr);
/*
* TIP #280: Release the location data associated with this Proc
@@ -2200,9 +2150,9 @@ TclProcCleanupProc(
Tcl_DecrRefCount(cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
- ckfree(cfPtr->line);
+ Tcl_Free(cfPtr->line);
cfPtr->line = NULL;
- ckfree(cfPtr);
+ Tcl_Free(cfPtr);
}
Tcl_DeleteHashEntry(hePtr);
}
@@ -2312,7 +2262,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
- ProcSetInternalRep(objPtr, procPtr);
+ ProcSetIntRep(objPtr, procPtr);
}
return objPtr;
@@ -2341,9 +2291,9 @@ ProcBodyDup(
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
Proc *procPtr;
- ProcGetInternalRep(srcPtr, procPtr);
+ ProcGetIntRep(srcPtr, procPtr);
- ProcSetInternalRep(dupPtr, procPtr);
+ ProcSetIntRep(dupPtr, procPtr);
}
/*
@@ -2371,7 +2321,7 @@ ProcBodyFree(
{
Proc *procPtr;
- ProcGetInternalRep(objPtr, procPtr);
+ ProcGetIntRep(objPtr, procPtr);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
@@ -2400,12 +2350,12 @@ DupLambdaInternalRep(
Proc *procPtr;
Tcl_Obj *nsObjPtr;
- LambdaGetInternalRep(srcPtr, procPtr, nsObjPtr);
+ LambdaGetIntRep(srcPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
procPtr->refCount++;
- LambdaSetInternalRep(copyPtr, procPtr, nsObjPtr);
+ LambdaSetIntRep(copyPtr, procPtr, nsObjPtr);
}
static void
@@ -2416,7 +2366,7 @@ FreeLambdaInternalRep(
Proc *procPtr;
Tcl_Obj *nsObjPtr;
- LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
if (procPtr->refCount-- <= 1) {
@@ -2450,7 +2400,7 @@ SetLambdaFromAny(
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
- Tcl_GetString(objPtr)));
+ TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
return TCL_ERROR;
}
@@ -2536,12 +2486,12 @@ SetLambdaFromAny(
* location (line of 2nd list element).
*/
- cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
+ cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame));
TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
- cfPtr->line = (int *)ckalloc(sizeof(int));
+ cfPtr->line = (int *)Tcl_Alloc(sizeof(int));
cfPtr->line[0] = buf[1];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
@@ -2590,7 +2540,7 @@ SetLambdaFromAny(
* conversion to lambdaType.
*/
- LambdaSetInternalRep(objPtr, procPtr, nsObjPtr);
+ LambdaSetIntRep(objPtr, procPtr, nsObjPtr);
return TCL_OK;
}
@@ -2603,13 +2553,13 @@ TclGetLambdaFromObj(
Proc *procPtr;
Tcl_Obj *nsObjPtr;
- LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
if (procPtr == NULL) {
if (SetLambdaFromAny(interp, objPtr) != TCL_OK) {
return NULL;
}
- LambdaGetInternalRep(objPtr, procPtr, nsObjPtr);
+ LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
}
assert(procPtr != NULL);
@@ -2650,7 +2600,7 @@ Tcl_ApplyObjCmd(
int
TclNRApplyObjCmd(
- TCL_UNUSED(ClientData),
+ TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2754,13 +2704,14 @@ MakeLambdaError(
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
- int overflow, limit = 60, nameLen;
- const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
+ unsigned int overflow, limit = 60;
+ size_t nameLen;
+ const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (lambda term \"%.*s%s\" line %d)",
- (overflow ? limit : nameLen), procName,
+ (int)(overflow ? limit : nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
generated by cgit v0.12 at 2024-09-28 01:28:05 (GMT)