summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/proc.n15
-rw-r--r--generic/tclCmdIL.c3
-rw-r--r--generic/tclInt.h21
-rw-r--r--generic/tclProc.c200
-rw-r--r--generic/tclVar.c4
-rw-r--r--tests/info.test31
-rw-r--r--tests/oo.test6
-rw-r--r--tests/proc-enh.test78
8 files changed, 103 insertions, 255 deletions
diff --git a/doc/proc.n b/doc/proc.n
index 78fa471..2dc2e3b 100644
--- a/doc/proc.n
+++ b/doc/proc.n
@@ -136,18 +136,13 @@ as potential switches. On call-site, the related switch value will be
set on the argument if one of the switch names is used.
See \fBNAMED ARGUMENTS HANDLING\fR below for details on named arguments.
.TP
-\fB-upvar \fIbool\fR
+\fB-upvar \fIlevel\fR
.VS
-If \fIbool\fR is set to true, this will cause the related variable,
-rather than taking the parameter value, to become an alias
-to the variable in caller's scope corresponding to the parameter value.
+When defined, this will cause the related variable, rather than taking
+the parameter value, to become an alias to the variable in the frame
+at level \fIlevel\fR corresponding to the parameter value. \fILevel\fR
+may have any of the forms permitted for the \fBupvar\fR command.
This specifier is incompatible with the \fB-switch\fR specifier.
-.TP
-\fB-varname \fIvarname\fR
-.VS
-Defines a new variable named \fIvarname\fR which will be added in the
-procedure with the original value of the parameter. This is mostly used
-with \fB-upvar 1\fR to access the name of the linked variable.
.VE
.SS "NAMED ARGUMENTS HANDLING"
.VS
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 7898ef4..99f6da9 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -559,8 +559,7 @@ InfoArgSpecCmd(
};
static const char *const specifiers[] = {
/* supported specifiers, must be ordered */
- "-default", "-name", "-required", "-switch", "-upvar",
- "-varname", NULL
+ "-default", "-name", "-required", "-switch", "-upvar", NULL
};
enum Types {
ARGSPEC_PROC, ARGSPEC_LAMBDA, ARGSPEC_CONSTRUCTOR, ARGSPEC_METHOD,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0c18631..b5254ca 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -703,13 +703,6 @@ typedef struct VarInHash {
* specification.
* VAR_ARG_UPVAR 1 means that this argument has been defined
* using the -upvar extended arg specification.
- * VAR_ARG_HAS_VARNAME 1 means that this variable has been specified
- * with the -varname specifier and that a
- * dedicated variable has been created to store
- * the original value.
- * VAR_ARG_IS_VARNAME 1 means that this variable has been added to
- * store the name of a passed-by-name argument,
- * defined using an extended arg specification.
* VAR_ARG_OPTIONAL 1 means that this argument is not required to
* be specified on call-site.
*/
@@ -755,9 +748,7 @@ typedef struct VarInHash {
#define VAR_RESOLVED 0x8000
#define VAR_NAMED_GROUP 0x10000
#define VAR_ARG_UPVAR 0x20000
-#define VAR_ARG_IS_VARNAME 0x40000
-#define VAR_ARG_HAS_VARNAME 0x80000
-#define VAR_ARG_OPTIONAL 0x100000
+#define VAR_ARG_OPTIONAL 0x40000
/*
* Macros to ensure that various flag bits are set properly for variables.
@@ -865,7 +856,7 @@ typedef struct VarInHash {
((varPtr)->flags & VAR_DEAD_HASH)
#define TclIsVarWithExtArgs(varPtr) \
- ((varPtr)->flags & (VAR_NAMED_GROUP|VAR_ARG_UPVAR|VAR_ARG_HAS_VARNAME|VAR_ARG_OPTIONAL))
+ ((varPtr)->flags & (VAR_NAMED_GROUP|VAR_ARG_UPVAR|VAR_ARG_OPTIONAL))
#define TclGetVarNsPtr(varPtr) \
(TclIsVarInHash(varPtr) \
@@ -960,14 +951,13 @@ typedef struct ExtendedArgSpec {
struct NamedGroupEntry *lastNamedEntryPtr;
/* Pointer to the last named parameter entry
* defined on the proc argument. */
- int varnameIndex; /* Index of the local created to store the
- * name of the passed-by-name argument. Set
- * to -1 when not used. */
Tcl_HashTable *namedHashTable;
/* Pointer to the hash table created for a
* fast lookup of named entry. The pointer is
* only set on the first local of a named
* group. */
+ Tcl_Obj *upvarLevelPtr; /* Pointer to the level value specified using
+ * the -upvar specifier. */
} ExtendedArgSpec;
/*
@@ -3279,7 +3269,8 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclUpvarForExtArg(Tcl_Interp *interp,
- Tcl_Obj *varNamePtr, const char *localNameStr);
+ Tcl_Obj *frameNamePtr, Tcl_Obj *varNamePtr,
+ const char *localNameStr);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCount(int ch);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 298ba85..d6037f6 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -53,7 +53,6 @@ static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int ProcParseArgSpec(Tcl_Interp *interp,
const char *argSpec, int argIdx, int isLastArg,
CompiledLocal **localPtrPtr,
- CompiledLocal **lastLocalPtrPtr,
Tcl_HashTable **namedHashPtrPtr);
static inline int ProcCheckScalarArg(const char *arg, const char **err);
static void ProcCompiledLocalsFree(CompiledLocal *localPtr);
@@ -409,8 +408,8 @@ TclCreateProc(
int i, length, result, numArgs;
const char *args, *bytes;
register CompiledLocal *localPtr = NULL;
- CompiledLocal *newLocalPtr, *lastLocalPtr;
- int precompiled = 0, numLocalsDiff = 0;
+ CompiledLocal *newLocalPtr;
+ int precompiled = 0;
Tcl_HashTable *hPtr = NULL;
if (bodyPtr->typePtr == &tclProcBodyType) {
@@ -513,8 +512,8 @@ TclCreateProc(
for (i = 0; i < numArgs; i++) {
- result = ProcParseArgSpec(interp, argArray[i], i + numLocalsDiff,
- (i == numArgs - 1), &newLocalPtr, &lastLocalPtr, &hPtr);
+ result = ProcParseArgSpec(interp, argArray[i], i, (i == numArgs - 1),
+ &newLocalPtr, &hPtr);
if (result != TCL_OK) {
goto procError;
}
@@ -572,39 +571,17 @@ TclCreateProc(
localPtr->flags |= VAR_IS_ARGS;
}
- if (newLocalPtr != lastLocalPtr) {
- /* adjust numArgs/numCompiledLocals if ProcParseArgSpec
- * has created additional locals for varname.
- */
- int diff = lastLocalPtr->frameIndex - newLocalPtr->frameIndex;
- numLocalsDiff += diff;
- while ((diff-- > 0) && (localPtr != NULL)) {
- localPtr = localPtr->nextPtr;
- }
- }
-
Tcl_DecrRefCount(argSpec1);
Tcl_DecrRefCount(argSpec2);
ProcCompiledLocalsFree(newLocalPtr);
localPtr = localPtr->nextPtr;
} else {
- if (newLocalPtr != lastLocalPtr) {
- /* adjust numArgs/numCompiledLocals if ProcParseArgSpec
- * has created additional locals for varname.
- */
- int diff = lastLocalPtr->frameIndex - newLocalPtr->frameIndex;
- procPtr->numArgs += diff;
- procPtr->numCompiledLocals += diff;
- numLocalsDiff += diff;
- }
-
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = newLocalPtr;
- procPtr->lastLocalPtr = lastLocalPtr;
} else {
procPtr->lastLocalPtr->nextPtr = newLocalPtr;
- procPtr->lastLocalPtr = lastLocalPtr;
}
+ procPtr->lastLocalPtr = newLocalPtr;
if (TclIsVarWithExtArgs(newLocalPtr)) {
procPtr->flags |= PROC_HAS_EXT_ARG_SPEC;
@@ -789,16 +766,14 @@ ProcAddNamedGroupEntry(
*
* Given an argument specification defined either using old-style
* (arg ?default?) or extended argument specification (TIP#457),
- * create and initialize the related CompiledLocal entry, including
- * any required additional entries (for '-varname name').
+ * create and initialize the related CompiledLocal entry.
*
* Results:
* Returns TCL_OK on success, along with a pointer to the created
- * CompiledLocal entry and a pointer to the last CompiledLocal entry.
- * A Tcl_HashTable object is shared between all contiguous named
- * parameters, it is created when parsing the first entry.
- * Returns TCL_ERROR and set an error if the argument specification
- * is not valid.
+ * CompiledLocal entry. A Tcl_HashTable object is shared between
+ * all contiguous named parameters, it is created when parsing the
+ * first entry. Returns TCL_ERROR and set an error if the argument
+ * specification is not valid.
*
* Side effects:
* CompiledLocal and related entries are allocated. A Tcl_HashTable
@@ -817,22 +792,18 @@ ProcParseArgSpec(
CompiledLocal **localPtrPtr,
/* On success, store the created CompiledLocal
* here. */
- CompiledLocal **lastLocalPtrPtr,
- /* On sucess, store the pointer to the last
- * created CompiledLocal here. */
Tcl_HashTable **namedHashPtrPtr)
/* Shared Tcl_HashTable created on the first
* named parameter entry to speedup lookups
* of named parameters. */
{
- CompiledLocal *localPtr = NULL, *varNamePtr = NULL;
+ CompiledLocal *localPtr = NULL;
ExtendedArgSpec *argSpecPtr;
const char **fieldValues = NULL;
int fieldCount, length;
const char *err;
- Tcl_Obj *boolObj;
int required = -1, hasSwitch = 0;
- int result, i, j, boolVal;
+ int result, i, j;
/*
* Divide the argument specifier into a list.
@@ -891,7 +862,6 @@ ProcParseArgSpec(
}
*localPtrPtr = localPtr;
- *lastLocalPtrPtr = localPtr;
*namedHashPtrPtr = NULL;
ckfree(fieldValues);
return TCL_OK;
@@ -904,8 +874,8 @@ ProcParseArgSpec(
argSpecPtr = ckalloc(sizeof(ExtendedArgSpec));
argSpecPtr->firstNamedEntryPtr = NULL;
argSpecPtr->lastNamedEntryPtr = NULL;
- argSpecPtr->varnameIndex = -1;
argSpecPtr->namedHashTable = NULL;
+ argSpecPtr->upvarLevelPtr = NULL;
localPtr->argSpecPtr = argSpecPtr;
for (i = 1 ; i < fieldCount ; i += 2) {
@@ -1016,60 +986,27 @@ ProcParseArgSpec(
&& (strcmp(fieldValues[i], "-upvar") == 0)) {
/*
- * Handle '-upvar bool', set or unset VAR_ARG_UPVAR flag.
+ * Handle '-upvar level', set upvarLevelPtr and VAR_ARG_UPVAR
+ * flag.
*/
- boolObj = Tcl_NewStringObj(fieldValues[i+1], -1);
- Tcl_IncrRefCount(boolObj);
- result = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- TclDecrRefCount(boolObj);
+ const char *levelStr = fieldValues[i+1];
+ int level;
- if (result != TCL_OK) {
+ if (Tcl_GetInt(NULL, (*levelStr == '#') ? levelStr+1 : levelStr,
+ &level) != TCL_OK || level < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "Invalid boolean \"%s\" for -upvar arg specifier",
- fieldValues[i+1]));
+ "Invalid level \"%s\" for -upvar arg specifier",
+ levelStr));
goto parseError;
- } else if (boolVal) {
- localPtr->flags |= VAR_ARG_UPVAR;
- } else {
- localPtr->flags &= VAR_ARG_UPVAR;
}
- } else if ((length == 8)
- && (strcmp(fieldValues[i], "-varname") == 0)) {
-
- /*
- * Handle '-varname name', create variable, set varnameIndex
- */
-
- const char *err;
- length = strlen(fieldValues[i+1]);
- if (length == 0) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "varname argument with no name", -1));
- goto parseError;
- } else if (ProcCheckScalarArg(fieldValues[i+1], &err) != TCL_OK) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "varname parameter \"%s\" %s", fieldValues[i+1], err));
- goto parseError;
- } else if (varNamePtr != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "varname already set", -1));
- goto parseError;
+ if (argSpecPtr->upvarLevelPtr != NULL) {
+ Tcl_DecrRefCount(argSpecPtr->upvarLevelPtr);
}
-
- varNamePtr = ckalloc(TclOffset(CompiledLocal, name) + length+1);
- varNamePtr->nextPtr = NULL;
- varNamePtr->nameLength = length;
- varNamePtr->frameIndex = argIdx + 1;
- varNamePtr->flags = VAR_ARG_IS_VARNAME;
- varNamePtr->defValuePtr = NULL;
- varNamePtr->resolveInfo = NULL;
- varNamePtr->argSpecPtr = NULL;
- memcpy(varNamePtr->name, fieldValues[i+1], length + 1);
- argSpecPtr->varnameIndex = varNamePtr->frameIndex;
- localPtr->flags |= VAR_ARG_HAS_VARNAME;
- localPtr->nextPtr = varNamePtr;
+ argSpecPtr->upvarLevelPtr = Tcl_NewStringObj(levelStr, -1);
+ Tcl_IncrRefCount(argSpecPtr->upvarLevelPtr);
+ localPtr->flags |= VAR_ARG_UPVAR;
} else if ((length == 9)
&& (strcmp(fieldValues[i], "-required") == 0)) {
@@ -1079,6 +1016,9 @@ ProcParseArgSpec(
* to set VAR_ARG_OPTIONAL flag depending on the other specifiers.
*/
+ Tcl_Obj *boolObj;
+ int boolVal;
+
boolObj = Tcl_NewStringObj(fieldValues[i+1], -1);
Tcl_IncrRefCount(boolObj);
result = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
@@ -1112,21 +1052,6 @@ ProcParseArgSpec(
"-upvar can't be used with -switch", -1));
goto parseError;
}
- if (localPtr->flags & VAR_ARG_HAS_VARNAME) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "-varname can't be used with -switch", -1));
- goto parseError;
- }
- }
-
- if (varNamePtr != NULL) {
- /* Argument created to handle '-varname arg' specifier must have
- * the VAR_NAMED_GROUP flag when the related argument is part of
- * a named group. This is required when searching the end of the
- * named group. */
- if (localPtr->flags & VAR_NAMED_GROUP) {
- varNamePtr->flags |= VAR_NAMED_GROUP;
- }
}
if ((required == 1) && (localPtr->defValuePtr)) {
@@ -1137,7 +1062,7 @@ ProcParseArgSpec(
} else if ((required == 0)
|| ((required == -1) && (localPtr->flags & VAR_NAMED_GROUP))) {
/* Variable is optional if '-required 0' has been explicitely set,
- * or if is part of a named group and no '-requirement' specifier
+ * or if is part of a named group and no '-required' specifier
* has been used. */
localPtr->flags |= VAR_ARG_OPTIONAL;
}
@@ -1148,7 +1073,6 @@ ProcParseArgSpec(
}
*localPtrPtr = localPtr;
- *lastLocalPtrPtr = (varNamePtr != NULL) ? varNamePtr : localPtr;
ckfree(fieldValues);
return TCL_OK;
@@ -2121,12 +2045,7 @@ InitArgsWithOptions(
for (iLocal = 0, iArg = 0, localPtr = procPtr->firstLocalPtr;
iLocal < numArgs;
iLocal++, localPtr = localPtr->nextPtr) {
- if (!TclIsVarArgument(localPtr)) {
-
- /* most probably a local allocated for -varname */
- continue;
-
- } else if (localPtr->flags & VAR_IS_ARGS) {
+ if (localPtr->flags & VAR_IS_ARGS) {
/*
* 'args' last argument, copy remaining arguments (can be empty)
@@ -2194,8 +2113,9 @@ InitArgsWithOptions(
}
if (namedGroupPtr->localPtr->flags & VAR_ARG_UPVAR) {
- result = TclUpvarForExtArg(interp, objPtr,
- namedGroupPtr->localPtr->name);
+ result = TclUpvarForExtArg(interp,
+ namedGroupPtr->localPtr->argSpecPtr->upvarLevelPtr,
+ objPtr, namedGroupPtr->localPtr->name);
if (result != TCL_OK) {
return result;
}
@@ -2209,14 +2129,6 @@ InitArgsWithOptions(
Tcl_IncrRefCount(objPtr);
}
- if (namedGroupPtr->localPtr->flags & VAR_ARG_HAS_VARNAME) {
- localVarPtr = &(varPtr[namedGroupPtr->localPtr->argSpecPtr->varnameIndex]);
- if (localVarPtr->value.objPtr != NULL) {
- Tcl_DecrRefCount(localVarPtr->value.objPtr);
- }
- localVarPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr);
- }
}
/*
@@ -2252,7 +2164,9 @@ InitArgsWithOptions(
objPtr = argObjs[iArg++];
if (localPtr->flags & VAR_ARG_UPVAR) {
- result = TclUpvarForExtArg(interp, objPtr, localPtr->name);
+ result = TclUpvarForExtArg(interp,
+ localPtr->argSpecPtr->upvarLevelPtr, objPtr,
+ localPtr->name);
if (result != TCL_OK) {
return result;
}
@@ -2261,15 +2175,6 @@ InitArgsWithOptions(
Tcl_IncrRefCount(objPtr);
}
- if (localPtr->flags & VAR_ARG_HAS_VARNAME) {
- localVarPtr = &(varPtr[localPtr->argSpecPtr->varnameIndex]);
- if (localVarPtr->value.objPtr != NULL) {
- Tcl_DecrRefCount(localVarPtr->value.objPtr);
- }
- localVarPtr->value.objPtr = objPtr;
- Tcl_IncrRefCount(objPtr);
- }
-
} else if (localPtr->defValuePtr) {
/*
@@ -2368,11 +2273,11 @@ TclProcGetArgSpec(
Tcl_NewBooleanObj(0));
}
- if (localPtr->flags & VAR_ARG_UPVAR) {
+ if ((localPtr->argSpecPtr != NULL) && (localPtr->flags & VAR_ARG_UPVAR)) {
Tcl_ListObjAppendElement(interp, listObjPtr,
Tcl_NewStringObj("-upvar", -1));
Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewBooleanObj(1));
+ localPtr->argSpecPtr->upvarLevelPtr);
}
if ((localPtr->argSpecPtr != NULL)
@@ -2417,22 +2322,6 @@ TclProcGetArgSpec(
Tcl_ListObjAppendElement(interp, listObjPtr, switchListPtr);
}
- if ((localPtr->argSpecPtr != NULL)
- && (localPtr->argSpecPtr->varnameIndex >= 0)) {
- CompiledLocal *upLocal = localPtr->nextPtr;
- while ((upLocal != NULL)
- && (upLocal->frameIndex != localPtr->argSpecPtr->varnameIndex)) {
- upLocal = upLocal->nextPtr;
- }
-
- if (upLocal != NULL) {
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj("-varname", -1));
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(upLocal->name, upLocal->nameLength));
- }
- }
-
return listObjPtr;
}
@@ -3131,6 +3020,17 @@ ProcCompiledLocalsFree(
entryPtr = nextEntryPtr;
}
+ if (localPtr->argSpecPtr->namedHashTable != NULL) {
+ Tcl_HashTable *hTablePtr;
+ hTablePtr = localPtr->argSpecPtr->namedHashTable;
+ Tcl_DeleteHashTable(hTablePtr);
+ ckfree(hTablePtr);
+ }
+
+ if (localPtr->argSpecPtr->upvarLevelPtr != NULL) {
+ Tcl_DecrRefCount(localPtr->argSpecPtr->upvarLevelPtr);
+ }
+
ckfree(localPtr->argSpecPtr);
}
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 82a49bd..01ef6a7 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -4437,6 +4437,8 @@ int
TclUpvarForExtArg(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
+ Tcl_Obj *frameNamePtr, /* Name of the frame containing the source
+ * variable. */
Tcl_Obj *varNamePtr, /* Name of variable in interp to link to. */
const char *localNameStr) /* Name of link variable. */
{
@@ -4444,7 +4446,7 @@ TclUpvarForExtArg(
CallFrame *framePtr;
Tcl_Obj *localNamePtr;
- if (TclObjGetFrame(interp, NULL, &framePtr) == -1) {
+ if (TclObjGetFrame(interp, frameNamePtr, &framePtr) == -1) {
return TCL_ERROR;
}
diff --git a/tests/info.test b/tests/info.test
index afa4316..ad32158 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -2441,26 +2441,21 @@ test info-40-6 {info argspec proc on local variable} -body {
proc p {a} {set x 0}
info argspec proc p x
} -returnCodes error -result {proc "p" doesn't have an argument "x"}
-test info-40-7 {info argspec proc on varname name} -body {
- proc p {{a -varname up}} {}
- info argspec proc p up
-} -returnCodes error -result {proc "p" doesn't have an argument "up"}
-test info-40-8 {info argspec proc with new-style proc} {
+test info-40-7 {info argspec proc with new-style proc} {
proc p {
{ a -default 2 }
- { b -upvar 1 }
- { c -upvar 1 -varname up }
- { d -required 0 }
+ { b -upvar #1 }
+ { c -required 0 }
} {}
- list [info argspec proc p a] [info argspec proc p b] [info argspec proc p c] [info argspec proc p d]
-} {{-default 2} {-upvar 1} {-upvar 1 -varname up} {-required 0}}
-test info-40-9 {info argspec proc with multiple named args} {
+ list [info argspec proc p a] [info argspec proc p b] [info argspec proc p c]
+} {{-default 2} {-upvar #1} {-required 0}}
+test info-40-8 {info argspec proc with multiple named args} {
proc p {
{ a -default 0 -name val -switch {flag1 { flag2 22 }} -name {val2}}
} {}
info argspec proc p a
} {-default 0 -name {val val2} -switch {flag1 {flag2 22}}}
-test info-40-10 {info argspec proc without arg} {
+test info-40-9 {info argspec proc without arg} {
proc p {
{ a -default 2 }
{ b -name {B B1} -required 1 }
@@ -2468,21 +2463,21 @@ test info-40-10 {info argspec proc without arg} {
} {}
info argspec proc p
} {{a -default 2} {b -required 1 -name {B B1}} args}
-test info-40-11 {info argspec unknown type} -body {
+test info-40-10 {info argspec unknown type} -body {
info argspec foo
} -returnCodes error -result {bad type "foo": must be proc, lambda, constructor, method, objmethod, or specifiers}
-test info-40-12 {info argspec lambda} {
+test info-40-11 {info argspec lambda} {
set l [list {{a -name A} {b -default 5}} {list $a $b}]
list [info argspec lambda $l] [info argspec lambda $l a]
} {{{a -name A} {b -default 5}} {-name A}}
-test info-40-13 {info argspec lambda not a lambda} -body {
+test info-40-12 {info argspec lambda not a lambda} -body {
proc p {} {}
info argspec lambda p
} -returnCodes error -result {can't interpret "p" as a lambda expression}
-test info-40-14 {info argspec specifiers} {
+test info-40-13 {info argspec specifiers} {
info argspec specifiers
-} {-default -name -required -switch -upvar -varname}
-test info-40-15 {info argspec objmethod} -setup {
+} {-default -name -required -switch -upvar}
+test info-40-14 {info argspec objmethod} -setup {
oo::object create foo
} -body {
oo::objdefine foo method bar {a {b B} {c -switch {{C 1}} -default 0}} {}
diff --git a/tests/oo.test b/tests/oo.test
index 534cac4..3d28221 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -3802,16 +3802,16 @@ test oo-36.3 {"info object definition" with extended argspec} -setup {
oo::object create foo
} -body {
oo::objdefine foo method bar {a {b B} {c -switch {{C 1}} -default 0}
- {d -upvar true -varname up} args} {body}
+ {d -upvar 1} args} {body}
set result [info object definition foo bar]
} -cleanup {
foo destroy
-} -result {{a {b B} {c -default 0 -switch {{C 1}}} {d -upvar 1 -varname up} args} body}
+} -result {{a {b B} {c -default 0 -switch {{C 1}}} {d -upvar 1} args} body}
test oo-36.4 {"info class definition" with extended argspec} -setup {
oo::class create foo
} -body {
- oo::define foo method bar {a {b 8} {c -name C} {d -name D -upvar true}
+ oo::define foo method bar {a {b 8} {c -name C} {d -name D -upvar 1}
args} {body}
set result [info class definition foo bar]
} -cleanup {
diff --git a/tests/proc-enh.test b/tests/proc-enh.test
index 697dd62..b6cc7a4 100644
--- a/tests/proc-enh.test
+++ b/tests/proc-enh.test
@@ -70,51 +70,31 @@ test proc-enh-1.10 {argspec parsing error: two many fields in switch} {
proc p {{a -switch {{a b c}}}} {}
} msg] $msg $errorCode
} {1 {incorrect switch value "a b c"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.11 {argspec parsing error: upvar with no boolean} {
+test proc-enh-1.11 {argspec parsing error: upvar with bad level} {
list [catch {
proc p {{a -upvar foo}} {}
} msg] $msg $errorCode
-} {1 {Invalid boolean "foo" for -upvar arg specifier} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.12 {argspec parsing error: varname argument with no name} {
+} {1 {Invalid level "foo" for -upvar arg specifier} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
+test proc-enh-1.12 {argspec parsing error: upvar with bad level} {
list [catch {
- proc p {{a -varname {}}} {}
+ proc p {{a -upvar -1}} {}
} msg] $msg $errorCode
-} {1 {varname argument with no name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.13 {argspec parsing error: varname parameter is an array elt} {
- list [catch {
- proc p {{a -varname a(1)}} {}
- } msg] $msg $errorCode
-} {1 {varname parameter "a(1)" is an array element} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.14 {argspec parsing error: varname is not a simple name} {
- list [catch {
- proc p {{a -varname a::b}} {}
- } msg] $msg $errorCode
-} {1 {varname parameter "a::b" is not a simple name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.15 {argspec parsing error: varname set twice} {
- list [catch {
- proc p {{a -varname up1 -varname up2}} {}
- } msg] $msg $errorCode
-} {1 {varname already set} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.16 {argspec parsing error: required with no boolean} {
+} {1 {Invalid level "-1" for -upvar arg specifier} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
+test proc-enh-1.13 {argspec parsing error: required with no boolean} {
list [catch {
proc p {{a -required foo}} {}
} msg] $msg $errorCode
} {1 {Invalid boolean "foo" for -required arg specifier} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.16 {argspec parsing error: same arg name used twice} {
+test proc-enh-1.14 {argspec parsing error: same arg name used twice} {
list [catch {
proc p {{a -name A} {b -name B} {a2 -name A}} {}
} msg] $msg $errorCode
} {1 {named argument "A" has been used more than once in the same named group} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.17 {argspec parsing error: -upvar with -switch} {
+test proc-enh-1.15 {argspec parsing error: -upvar with -switch} {
list [catch {
proc p {{a -switch A -upvar 1}} {}
} msg] $msg $errorCode
} {1 {-upvar can't be used with -switch} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
-test proc-enh-1.18 {argspec parsing error: -varname with -switch} {
- list [catch {
- proc p {{a -switch A -varname va}} {}
- } msg] $msg $errorCode
-} {1 {-varname can't be used with -switch} {TCL OPERATION PROC FORMALARGUMENTFORMAT}}
# proc-enh-2.x: correct usage
test proc-enh-2.1 {correct usage: -default} {
@@ -153,29 +133,21 @@ test proc-enh-2.7 {correct usage: -required + -switch} {
list [p] [p -dbg]
} {unset dbg}
test proc-enh-2.8 {correct usage: -upvar} {
- proc p {{a -upvar 1}} {
- incr a; return $a
- }
- set i 5;
- if [info exists j] { unset j }
- list [p i] [p j] [list $i $j]
-} {6 1 {6 1}}
-test proc-enh-2.8 {correct usage: -upvar + -varname} {
- proc p {{a -varname up -upvar 1}} {
- incr a; list $up $a
- }
+ proc p {{a -upvar #0}} { incr a; return $a }
+ proc p2 {{a -upvar 2}} { incr a; return $a }
+ proc p3 {name} { p2 $name }
set i 5;
if [info exists j] { unset j }
- list [p i] [p j] [list $i $j]
-} {{i 6} {j 1} {6 1}}
-test proc-enh-2.9 {correct usage: -upvar + -varname + -name} {
- proc p {{a -varname up1 -upvar 1 -name A} {b -name B -upvar 1 -varname up2}} {
- incr a; incr b; list $up1 $a $up2 $b
+ list [p i] [p j] [p3 i] [list $i $j]
+} {6 1 7 {7 1}}
+test proc-enh-2.9 {correct usage: -upvar + -name} {
+ proc p {{a -upvar 1 -name A} {b -name B -upvar 1}} {
+ incr a; incr b; list $a $b
}
set i 5;
if [info exists j] { unset j }
list [p -B j -A i] [p -A j -B i] [list $i $j]
-} {{i 6 j 1} {j 2 i 7} {7 2}}
+} {{6 1} {2 7} {7 2}}
test proc-enh-2.10 {correct usage: end of named group} {
proc p {{a -name A -default 0} {b -default 1 -name B} args} {
list $a $b $args
@@ -190,12 +162,12 @@ test proc-enh-2.11 {correct usage: -upvar inside a named group (not last one)} {
list [p -var i -incr 2] [p -incr 3 -var i] [p -var i]
} {2 5 6}
test proc-enh-2.12 {correct usage: -upvar inside a named group + end-of-option marker} {
- proc p {{v -name var -upvar 1 -varname nm} {i -default 1 -name incr} args} {
- incr v $i; list $nm $v $args
+ proc p {{v -name var -upvar 1} {i -default 1 -name incr} args} {
+ incr v $i; list $v $args
}
set i 0
list [p -var i] [p -var i -- -incr 3] [p -var i -- a b c] [p -var i -- -- abc]
-} {{i 1 {}} {i 2 {-incr 3}} {i 3 {a b c}} {i 4 {-- abc}}}
+} {{1 {}} {2 {-incr 3}} {3 {a b c}} {4 {-- abc}}}
test proc-enh-2.13 {correct usage: two distinct named group} {
proc p {{a -switch A -default 0} {b -switch B -default 0} c {d -switch D -default 0} {e -switch E -default 0}} {
list $a $b $c $d $e
@@ -215,12 +187,6 @@ test proc-enh-2.15 {correct usage: multi-elems list must not be handled as a nam
set l [list -Z 1]
p $l
} {0 {-Z 1}}
-test proc-enh-2.16 {correct usage: varname without upvar} {
- proc p {{a -name A -varname vn1} {b -varname vn2}} {
- list $a $vn1 $b $vn2
- };
- p -A i j
-} {i i j j}
# proc-enh-3.x: wrong # args
test proc-enh-3.1 {wrong # args: -name arg without value} {
@@ -276,8 +242,8 @@ test proc-enh-5.2 {precompiled: inconsistent arg spec} -body {
catch {rename t ""}
} -result {procedure "t": formal parameter "z" has argument spec inconsistent with precompiled body}
test proc-enh-5.3 {precompiled: with upvar arg} -body {
- proc p {x {y -upvar 1 -varname up} z} { }
- procbodytest::proc t {x {y -upvar 1 -varname up} z} p
+ proc p {x {y -upvar 1} z} { }
+ procbodytest::proc t {x {y -upvar 1} z} p
} -constraints procbodytest -result {}
# proc-enh-6.x: apply/lambda
generated by cgit v0.12 at 2024-10-11 08:55:35 (GMT)