From f02f69d38c09e7aea70bbc7102301bbd0cb0d3f3 Mon Sep 17 00:00:00 2001 From: mlafon Date: Fri, 5 May 2017 22:57:25 +0000 Subject: TIP#457: Remove -varname, add level for -upvar --- doc/proc.n | 15 ++-- generic/tclCmdIL.c | 3 +- generic/tclInt.h | 21 ++---- generic/tclProc.c | 200 +++++++++++++--------------------------------------- generic/tclVar.c | 4 +- tests/info.test | 31 ++++---- tests/oo.test | 6 +- tests/proc-enh.test | 78 ++++++-------------- 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 -- cgit v0.12