summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c75
1 files changed, 34 insertions, 41 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 8c2309d..f2a52a7 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -80,7 +80,7 @@ const Tcl_ObjType tclProcBodyType = {
#define ProcGetIntRep(objPtr, procPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
- irPtr = Tcl_FetchIntRep((objPtr), &tclProcBodyType); \
+ irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \
(procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
@@ -126,7 +126,7 @@ static const Tcl_ObjType lambdaType = {
#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
- irPtr = Tcl_FetchIntRep((objPtr), &lambdaType); \
+ irPtr = TclFetchIntRep((objPtr), &lambdaType); \
(procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \
(nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
@@ -329,7 +329,7 @@ Tcl_ProcObjCmd(
* of all procs whose argument list is just _args_
*/
- if (Tcl_FetchIntRep(objv[3], &tclProcBodyType)) {
+ if (objv[3]->typePtr == &tclProcBodyType) {
goto done;
}
@@ -354,8 +354,7 @@ Tcl_ProcObjCmd(
* The argument list is just "args"; check the body
*/
- procBody = TclGetString(objv[3]);
- numBytes = objv[3]->length;
+ procBody = TclGetStringFromObj(objv[3], &numBytes);
if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
goto done;
}
@@ -408,11 +407,8 @@ TclCreateProc(
register Proc *procPtr = NULL;
int i, result, numArgs;
- size_t plen;
- const char *bytes, *argname, *argnamei;
- char argnamelast;
register CompiledLocal *localPtr = NULL;
- Tcl_Obj *defPtr, *errorObj, **argArray;
+ Tcl_Obj **argArray;
int precompiled = 0;
ProcGetIntRep(bodyPtr, procPtr);
@@ -449,6 +445,7 @@ TclCreateProc(
*/
if (Tcl_IsShared(bodyPtr)) {
+ const char *bytes;
size_t length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
@@ -511,8 +508,9 @@ TclCreateProc(
}
for (i = 0; i < numArgs; i++) {
- int fieldCount, nameLength;
- size_t valueLength;
+ const char *argname, *argnamei, *argnamelast;
+ int fieldCount;
+ size_t nameLength;
Tcl_Obj **fieldValues;
/*
@@ -525,7 +523,7 @@ TclCreateProc(
goto procError;
}
if (fieldCount > 2) {
- errorObj = Tcl_NewStringObj(
+ Tcl_Obj *errorObj = Tcl_NewStringObj(
"too many fields in argument specifier \"", -1);
Tcl_AppendObjToObj(errorObj, argArray[i]);
Tcl_AppendToObj(errorObj, "\"", -1);
@@ -542,33 +540,27 @@ TclCreateProc(
goto procError;
}
- argname = TclGetStringFromObj(fieldValues[0], &plen);
- nameLength = Tcl_NumUtfChars(argname, plen);
- if (fieldCount == 2) {
- const char * value = TclGetString(fieldValues[1]);
- valueLength = Tcl_NumUtfChars(value, fieldValues[1]->length);
- } else {
- valueLength = 0;
- }
+ argname = TclGetStringFromObj(fieldValues[0], &nameLength);
/*
* Check that the formal parameter name is a scalar.
*/
argnamei = argname;
- argnamelast = argname[plen-1];
- while (plen--) {
- if (argnamei[0] == '(') {
- if (argnamelast == ')') { /* We have an array element. */
+ argnamelast = Tcl_UtfPrev(argname + nameLength, argname);
+ while (argnamei < argnamelast) {
+ if (*argnamei == '(') {
+ 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;
}
- } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) {
- errorObj = Tcl_NewStringObj("formal parameter \"", -1);
+ } else if (*argnamei == ':' && *(argnamei+1) == ':') {
+ Tcl_Obj *errorObj = Tcl_NewStringObj(
+ "formal parameter \"", -1);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
Tcl_SetObjResult(interp, errorObj);
@@ -592,7 +584,7 @@ TclCreateProc(
*/
if ((localPtr->nameLength != nameLength)
- || (Tcl_UtfNcmp(localPtr->name, argname, nameLength))
+ || (memcmp(localPtr->name, argname, nameLength) != 0)
|| (localPtr->frameIndex != i)
|| !(localPtr->flags & VAR_ARGUMENT)
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
@@ -610,13 +602,15 @@ TclCreateProc(
*/
if (localPtr->defValuePtr != NULL) {
- const char *tmpPtr = TclGetString(localPtr->defValuePtr);
- size_t tmpLength = localPtr->defValuePtr->length;
-
- if ((valueLength != tmpLength) ||
- Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) {
- errorObj = Tcl_ObjPrintf(
- "procedure \"%s\": formal parameter \"" ,procName);
+ size_t tmpLength, valueLength;
+ const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength);
+ const char *value = TclGetStringFromObj(fieldValues[1], &valueLength);
+
+ if ((valueLength != tmpLength)
+ || memcmp(value, tmpPtr, tmpLength) != 0
+ ) {
+ Tcl_Obj *errorObj = Tcl_ObjPrintf(
+ "procedure \"%s\": formal parameter \"", procName);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" has "
"default value inconsistent with precompiled body", -1);
@@ -663,7 +657,7 @@ TclCreateProc(
if ((i == numArgs - 1)
&& (localPtr->nameLength == 4)
&& (localPtr->name[0] == 'a')
- && (strcmp(localPtr->name, "args") == 0)) {
+ && (memcmp(localPtr->name, "args", 4) == 0)) {
localPtr->flags |= VAR_IS_ARGS;
}
}
@@ -681,9 +675,8 @@ TclCreateProc(
localPtr = procPtr->firstLocalPtr;
procPtr->firstLocalPtr = localPtr->nextPtr;
- defPtr = localPtr->defValuePtr;
- if (defPtr != NULL) {
- Tcl_DecrRefCount(defPtr);
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_DecrRefCount(localPtr->defValuePtr);
}
Tcl_Free(localPtr);
@@ -796,7 +789,7 @@ TclObjGetFrame(
level = curLevel - level;
result = 1;
}
- } else if ((irPtr = Tcl_FetchIntRep(objPtr, &levelReferenceType))) {
+ } else if ((irPtr = TclFetchIntRep(objPtr, &levelReferenceType))) {
level = irPtr->wideValue;
result = 1;
} else {
@@ -2429,7 +2422,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;
}
generated by cgit v0.12 at 2025-04-02 12:46:16 (GMT)