summaryrefslogtreecommitdiffstats
path: root/generic/tclProc.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclProc.c')
-rw-r--r--generic/tclProc.c185
1 files changed, 92 insertions, 93 deletions
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 373192c..212b680 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -124,11 +124,10 @@ Tcl_ProcObjCmd(
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
- const char *fullName;
- const char *procName, *procArgs, *procBody;
+ const char *procName;
+ const char *simpleName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
- Tcl_DString ds;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "name args body");
@@ -141,29 +140,21 @@ Tcl_ProcObjCmd(
* namespace.
*/
- fullName = TclGetString(objv[1]);
- TclGetNamespaceForQualName(interp, fullName, NULL, 0,
- &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ procName = TclGetString(objv[1]);
+ TclGetNamespaceForQualName(interp, procName, NULL, 0,
+ &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
- fullName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
- if (procName == NULL) {
+ if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
- fullName));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
- return TCL_ERROR;
- }
- if ((nsPtr != iPtr->globalNsPtr)
- && (procName != NULL) && (procName[0] == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create procedure \"%s\" in non-global namespace with"
- " name starting with \":\"", procName));
+ procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
return TCL_ERROR;
}
@@ -172,31 +163,16 @@ Tcl_ProcObjCmd(
* Create the data structure to represent the procedure.
*/
- if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
+ if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3],
&procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
- Tcl_AddErrorInfo(interp, procName);
+ Tcl_AddErrorInfo(interp, simpleName);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
- /*
- * Now create a command for the procedure. This will initially be in the
- * current namespace unless the procedure's name included namespace
- * qualifiers. To create the new command in the right namespace, we
- * generate a fully qualified name for it.
- */
-
- Tcl_DStringInit(&ds);
- if (nsPtr != iPtr->globalNsPtr) {
- Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
- TclDStringAppendLiteral(&ds, "::");
- }
- Tcl_DStringAppend(&ds, procName, -1);
-
- cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
- TclNRInterpProc, procPtr, TclProcDeleteProc);
- Tcl_DStringFree(&ds);
+ cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
+ TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc);
/*
* Now initialize the new procedure's cmdPtr field. This will be used
@@ -393,13 +369,13 @@ TclCreateProc(
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
- const char **argArray = NULL;
register Proc *procPtr;
- int i, length, result, numArgs;
- const char *args, *bytes, *p;
+ int i, result, numArgs, plen;
+ const char *bytes, *argname, *argnamei;
+ char argnamelast;
register CompiledLocal *localPtr = NULL;
- Tcl_Obj *defPtr;
+ Tcl_Obj *defPtr, *errorObj, **argArray;
int precompiled = 0;
if (bodyPtr->typePtr == &tclProcBodyType) {
@@ -436,6 +412,7 @@ TclCreateProc(
*/
if (Tcl_IsShared(bodyPtr)) {
+ int length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
@@ -473,12 +450,9 @@ TclCreateProc(
* argument specifier. If the body is precompiled, processing is limited
* to checking that the parsed argument is consistent with the one stored
* in the Proc.
- *
- * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS.
*/
- args = TclGetStringFromObj(argsPtr, &length);
- result = Tcl_SplitList(interp, args, &numArgs, &argArray);
+ result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray);
if (result != TCL_OK) {
goto procError;
}
@@ -502,28 +476,28 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength;
size_t valueLength;
- const char **fieldValues;
+ Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
- result = Tcl_SplitList(interp, argArray[i], &fieldCount,
+ result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount,
&fieldValues);
if (result != TCL_OK) {
goto procError;
}
if (fieldCount > 2) {
- ckfree(fieldValues);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "too many fields in argument specifier \"%s\"",
- argArray[i]));
+ errorObj = Tcl_NewStringObj(
+ "too many fields in argument specifier \"", -1);
+ Tcl_AppendObjToObj(errorObj, argArray[i]);
+ Tcl_AppendToObj(errorObj, "\"", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
- ckfree(fieldValues);
+ if ((fieldCount == 0) || (fieldValues[0]->length == 0)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
@@ -531,9 +505,10 @@ TclCreateProc(
goto procError;
}
- nameLength = strlen(fieldValues[0]);
+ nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length);
if (fieldCount == 2) {
- valueLength = strlen(fieldValues[1]);
+ valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]),
+ fieldValues[1]->length);
} else {
valueLength = 0;
}
@@ -542,33 +517,29 @@ TclCreateProc(
* Check that the formal parameter name is a scalar.
*/
- p = fieldValues[0];
- while (*p != '\0') {
- if (*p == '(') {
- const char *q = p;
- do {
- q++;
- } while (*q != '\0');
- q--;
- if (*q == ')') { /* We have an array element. */
+ argname = Tcl_GetStringFromObj(fieldValues[0], &plen);
+ argnamei = argname;
+ argnamelast = argname[plen-1];
+ while (plen--) {
+ if (argnamei[0] == '(') {
+ if (argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
- fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_GetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- } else if ((*p == ':') && (*(p+1) == ':')) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "formal parameter \"%s\" is not a simple name",
- fieldValues[0]));
- ckfree(fieldValues);
+ } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) {
+ errorObj = Tcl_NewStringObj("formal parameter \"", -1);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
- p++;
+ argnamei = Tcl_UtfNext(argnamei);
}
if (precompiled) {
@@ -584,7 +555,7 @@ TclCreateProc(
*/
if ((localPtr->nameLength != nameLength)
- || (strcmp(localPtr->name, fieldValues[0]))
+ || (Tcl_UtfNcmp(localPtr->name, argname, nameLength))
|| (localPtr->frameIndex != i)
|| !(localPtr->flags & VAR_ARGUMENT)
|| (localPtr->defValuePtr == NULL && fieldCount == 2)
@@ -592,7 +563,6 @@ TclCreateProc(
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter %d is "
"inconsistent with precompiled body", procName, i));
- ckfree(fieldValues);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
@@ -607,12 +577,13 @@ TclCreateProc(
size_t tmpLength = localPtr->defValuePtr->length;
if ((valueLength != tmpLength) ||
- strncmp(fieldValues[1], tmpPtr, tmpLength)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "procedure \"%s\": formal parameter \"%s\" has "
- "default value inconsistent with precompiled body",
- procName, fieldValues[0]));
- ckfree(fieldValues);
+ Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) {
+ errorObj = Tcl_ObjPrintf(
+ "procedure \"%s\": formal parameter \"" ,procName);
+ Tcl_AppendObjToObj(errorObj, fieldValues[0]);
+ Tcl_AppendToObj(errorObj, "\" has "
+ "default value inconsistent with precompiled body", -1);
+ Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"BYTECODELIES", NULL);
goto procError;
@@ -632,7 +603,7 @@ TclCreateProc(
* local variables for the argument.
*/
- localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
+ localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -640,19 +611,18 @@ TclCreateProc(
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
- localPtr->nameLength = nameLength;
+ localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length);
localPtr->frameIndex = i;
localPtr->flags = VAR_ARGUMENT;
localPtr->resolveInfo = NULL;
if (fieldCount == 2) {
- localPtr->defValuePtr =
- Tcl_NewStringObj(fieldValues[1], valueLength);
+ localPtr->defValuePtr = fieldValues[1];
Tcl_IncrRefCount(localPtr->defValuePtr);
} else {
localPtr->defValuePtr = NULL;
}
- memcpy(localPtr->name, fieldValues[0], nameLength + 1);
+ memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
if ((i == numArgs - 1)
&& (localPtr->nameLength == 4)
&& (localPtr->name[0] == 'a')
@@ -660,12 +630,9 @@ TclCreateProc(
localPtr->flags |= VAR_IS_ARGS;
}
}
-
- ckfree(fieldValues);
}
*procPtrPtr = procPtr;
- ckfree(argArray);
return TCL_OK;
procError:
@@ -686,9 +653,6 @@ TclCreateProc(
}
ckfree(procPtr);
}
- if (argArray != NULL) {
- ckfree(argArray);
- }
return TCL_ERROR;
}
@@ -826,7 +790,7 @@ TclObjGetFrame(
level = curLevel - level;
result = 1;
} else if (objPtr->typePtr == &levelReferenceType) {
- level = (int) objPtr->internalRep.longValue;
+ level = (int) objPtr->internalRep.wideValue;
result = 1;
} else {
name = TclGetString(objPtr);
@@ -834,7 +798,7 @@ TclObjGetFrame(
if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) {
TclFreeIntRep(objPtr);
objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.longValue = level;
+ objPtr->internalRep.wideValue = level;
result = 1;
} else {
result = -1;
@@ -2416,7 +2380,7 @@ FreeLambdaInternalRep(
Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2;
- if (procPtr->refCount-- == 1) {
+ if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
@@ -2750,6 +2714,41 @@ MakeLambdaError(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetCmdFrameForProcedure --
+ *
+ * How to get the CmdFrame information for a procedure.
+ *
+ * Results:
+ * A pointer to the CmdFrame (only guaranteed to be valid until the next
+ * Tcl command is processed or the interpreter's state is otherwise
+ * modified) or a NULL if the information is not available.
+ *
+ * Side effects:
+ * none.
+ *
+ *----------------------------------------------------------------------
+ */
+
+CmdFrame *
+TclGetCmdFrameForProcedure(
+ Proc *procPtr) /* The procedure whose cmd-frame is to be
+ * looked up. */
+{
+ Tcl_HashEntry *hePtr;
+
+ if (procPtr == NULL || procPtr->iPtr == NULL) {
+ return NULL;
+ }
+ hePtr = Tcl_FindHashEntry(procPtr->iPtr->linePBodyPtr, procPtr);
+ if (hePtr == NULL) {
+ return NULL;
+ }
+ return (CmdFrame *) Tcl_GetHashValue(hePtr);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
generated by cgit v0.12 at 2025-12-05 00:04:46 (GMT)