Index: doc/info.n ================================================================== --- doc/info.n +++ doc/info.n @@ -27,10 +27,16 @@ . Returns a list containing the names of the arguments to procedure \fIprocname\fR, in order. \fIProcname\fR must be the name of a Tcl command procedure. .TP +\fBinfo argspec ?\fIarg ...\fR +. +Returns information about the arguments specification of Tcl-pure +procedures, lambda or class methods. The \fIsubcommand\fRs are +described in \fBARGSPEC INTROSPECTION\fR below. +.TP \fBinfo body \fIprocname\fR . Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be the name of a Tcl command procedure. .TP @@ -396,10 +402,85 @@ of its namespace. Note that a currently-visible variable may not yet .QW exist if it has not been set (e.g. a variable declared but not set by \fBvariable\fR). +.SS "ARGSPEC INTROSPECTION" +.VS +.PP +The following \fIsubcommand\fR values are supported by \fBinfo argspec\fR: +.VE +.TP +\fBinfo argspec constructor \fIclassName \fR?\fIarg\fR? +.VS +If \fIarg\fR is specified, returns a list containing the argument +specifiers which describe the argument \fIarg\fR of the constructor +of the class \fIclassName\fR. +If \fIarg\fR is not specified, returns a list containing the argument +specifiers list of all arguments of the constructor of the +class \fIclassName\fR. +.TP +\fBinfo argspec lambda \fIlambdaTerm \fR?\fIarg\fR? +.VS +If \fIarg\fR is specified, returns a list containing the argument +specifiers which describe the argument \fIarg\fR of the lambda +\fIlambdaTerm\fR. +If \fIarg\fR is not specified, returns a list containing the argument +specifiers list of all arguments of the lambda \fIlambdaTerm\fR. +.TP +\fBinfo argspec method \fIclassName methodName \fR?\fIarg\fR? +.VS +If \fIarg\fR is specified, returns a list containing the argument +specifiers which describe the argument \fIarg\fR of the method +\fImethodName\fR of the class \fIclassName\fR. +If \fIarg\fR is not specified, returns a list containing the argument +specifiers list of all arguments of the method \fImethodName\fR +of the class \fIclassName\fR. +.TP +\fBinfo argspec objmethod \fIobject methodName \fR?\fIarg\fR? +.VS +If \fIarg\fR is specified, returns a list containing the argument +specifiers which describe the argument \fIarg\fR of the method +\fImethodName\fR of the object \fIobject\fR. +If \fIarg\fR is not specified, returns a list containing the argument +specifiers list of all arguments of the method \fImethodName\fR +of the object \fIobject\fR. +.TP +\fBinfo argspec proc \fIprocName \fR?\fIarg\fR? +.VS +If \fIarg\fR is specified, returns a list containing the argument +specifiers which describe the argument \fIarg\fR of the procedure +\fIprocName\fR. +If \fIarg\fR is not specified, returns a list containing the argument +specifiers list of all arguments of the procedure \fIprocName\fR. +.TP +\fBinfo argspec specifiers +.VS +Returns a list containing the argument specifiers supported by the +current interpreter. +.PP +Note that the returned argument specifiers in all subcommands, except +\fIspecifiers\fR, may not be exactly the +same as the ones used during the procedure creation, but they are +strictly equivalents. +.VE +.PP +.CS +proc p {{a -name A -name arg} {b -required 1 -default def}} {} +info argspec proc p a + \fI\(-> returns {a -name {A arg}}\fR + +info argspec proc p + \fI\(-> returns {{a -name {A arg}} b}\fR +.CE +.PP +In the example above, \fI-name A -name arg\fR and \fI-name {A arg}\fR +are equivalent specifiers. Using \fI-required 1\fR and a default value +on a non-keyword argument is equivalent to using no specifiers, as the +default value is ignored when \fI-required 1\fR is used and will also +force the argument to be specified. +.VE .SS "CLASS INTROSPECTION" .VS 8.6 .PP The following \fIsubcommand\fR values are supported by \fBinfo class\fR: .VE 8.6 Index: doc/proc.n ================================================================== --- doc/proc.n +++ doc/proc.n @@ -28,23 +28,28 @@ the procedure is created in the specified namespace. \fIArgs\fR specifies the formal arguments to the procedure. It consists of a list, possibly empty, each of whose elements specifies one argument. Each argument specifier is also a list with either -one or two fields. If there is only a single field in the specifier +one, two fields or an odd number of fields. +If there is only a single field in the specifier then it is the name of the argument; if there are two fields, then -the first is the argument name and the second is its default value. +the first is the argument name and the second is its default value; +if there are an odd number of fields, then the first is the argument +name and the remaining fields are extended argument specifiers. +See \fBEXTENDED ARGUMENT SPECIFIERS\fR below for details on allowed +specifiers. Arguments with default values that are followed by non-defaulted arguments become required arguments; enough actual arguments must be supplied to allow all arguments up to and including the last required formal argument. .PP When \fIname\fR is invoked a local variable will be created for each of the formal arguments to the procedure; its value will be the value of corresponding argument in the invoking command or the argument's default value. -Actual arguments are assigned to formal arguments strictly in order. +Actual positional arguments are assigned to formal arguments strictly in order. Arguments with default values need not be specified in a procedure invocation. However, there must be enough actual arguments for all the formal arguments that do not have defaults, and there must not be any extra actual arguments. @@ -51,11 +56,15 @@ Arguments with default values that are followed by non-defaulted arguments become de-facto required arguments, though this may change in a future version of Tcl; portable code should ensure that all optional arguments come after all required arguments. .PP -There is one special case to permit procedures with +Named arguments, defined with the \fB-name\fR or \fB-switch\fR extended +argument specifiers have a specific handling detailed in +\fBNAMED ARGUMENTS HANDLING\fR below. +.PP +There is an other special case to permit procedures with variable numbers of arguments. If the last formal argument has the name .QW \fBargs\fR , then a call to the procedure may contain more actual arguments than the procedure has formal arguments. In this case, all of the actual arguments starting at the one that would be assigned to \fBargs\fR are combined into @@ -65,11 +74,12 @@ When \fIbody\fR is being executed, variable names normally refer to local variables, which are created automatically when referenced and deleted when the procedure returns. One local variable is automatically created for each of the procedure's arguments. Other variables can only be accessed by invoking one of the \fBglobal\fR, -\fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands. +\fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands or by +using the \fB-upvar 1\fR extended argument specifier. The current namespace when \fIbody\fR is executed will be the namespace that the procedure's name exists in, which will be the namespace that it was created in unless it has been changed with \fBrename\fR. '\" We may change this! It makes [variable] unstable when renamed and is @@ -80,10 +90,91 @@ \fBreturn\fR command. If the procedure does not execute an explicit \fBreturn\fR, then its return value is the value of the last command executed in the procedure's body. If an error occurs while executing the procedure body, then the procedure-as-a-whole will return that same error. +.SS "EXTENDED ARGUMENT SPECIFIERS" +.VS +.PP +The following extended specifiers can be used to define an argument: +.VE +.TP +\fB-default \fIvalue\fR +.VS +Set \fIvalue\fR as the default value for the argument. It is ignored +if \fB-required 1\fR is also used. +.TP +\fB-name \fInames\fR +.VS +Defines the argument to be a named argument. \fINames\fR can be string +or a list of strings, each string being added as a potential name for +this argument. If \fB-name\fR is used several times for the same argument, +all strings are added as potential names. See \fBNAMED ARGUMENTS HANDLING\fR +below for details on named arguments. +.TP +\fB-required \fIbool\fR +.VS +Defines that the argument is required or not to be set by the caller. +If \fIbool\fR is true, it is required to be set and any default value +is ignored. It is the default handling for non-named argument +without a default value. +If \fIbool\fR is false, it is not required to be set and the related +argument will be left unset if there is no default value. It is the +default handling for named argument. +.TP +\fB-switch \fIswitches\fR +.VS +Defines the argument to be a flag/switch named argument. \fISwitches\fR +is a list of potential switches for this argument. +Each switch is defined either as a +single string or as a list of a string and a value. When the switch is +defined as a single string, the string is used as both the switch name +and the switch value. +When the switch is defined as a list of two entries, the first one is +the switch name and the second one is the switch value. If \fB-switch\fR +is used several times for the same argument, all switches are added +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 \fIlevel\fR +.VS +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. +.VE +.SS "NAMED ARGUMENTS HANDLING" +.VS +.PP +Named argument are arguments defined using the \fB-name\fR or \fB-switch\fR +extended argument specifiers. They have a special handling on call-site. +All contiguous named arguments, called named group, are handled together, +they are not required to be declared in order, can be omited or declared +multiple times. +.PP +The handling of a named group is started when previous formal arguments have +been assigned. +Each named parameter uses a string starting with a dash character, followed +by the name of the related argument. If it is not a switch argument, it is +followed by the value to assign to the formal argument. +.PP +The handling of +a named group is ended if the next parameter does not start with a dash or is +the special \fB--\fR keyword. In the case where the arguments after the named +group are all non-optional positional arguments and do not end with \fBargs\fR, +the handling of the named group will also be ended when the number of remaining +parameters will be equal to the number of the remaining positional arguments. +When the handling of named argument has been ended, remaining parameters, +except the \fB--\fR keyword if used, are then assigned to +following positional arguments using the default handling. +.PP +It is recommended to explicitely use the \fB--\fR keyword if the next parameter +following the named group is a variable which may start with a dash, or if it +is an object which can be expensive to stringify. +.VE .SH EXAMPLES .PP This is a procedure that takes two arguments and prints both their sum and their product. It also returns the string .QW OK @@ -107,22 +198,46 @@ puts $arg } } .CE .PP -This procedure is a bit like the \fBincr\fR command, except it -multiplies the contents of the named variable by the value, which -defaults to \fB2\fR: +These procedures are a bit like the \fBincr\fR command, except they +multiply the contents of the named variable by the value, which +defaults to \fB2\fR. The second procedure uses extended argument +specifiers and especially the \fB-upvar\fR specifier: .PP .CS \fBproc\fR mult {varName {multiplier 2}} { upvar 1 $varName var set var [expr {$var * $multiplier}] } + +\fBproc\fR mult {{var -upvar 1} {multiplier -default 2}} { + set var [expr {$var * $multiplier}] +} +.CE +.PP +This is a procedure that uses named argument for the first two +arguments. \fILevel\fR defaults to \fB1\fR and can be defined +using either \fB-level \fIlevelValue\fR or one of the switches +\fB-debug\fR (\fB0\fR) or \fB-error\fR (\fB3\fR). \fITime\fR +can be defined using either \fB-time \fItimeValue\fR or +\fB-timestamp \fItimeValue\fR. If none is used, \fItime\fR will +be left unset in the procedure. +.PP +.CS +\fBproc\fR log { + {level -name level -switch {{debug 0} {error 3}} -default 1} + {time -name {time timestamp}} + {message} } { + if {![info exists time]} {set time [clock seconds]} + array set levels {0 DEBUG 1 INFO 2 WARN 3 ERROR} + puts "[clock format $time] : $levels($level) : $message" +} .CE .SH "SEE ALSO" info(n), unknown(n) .SH KEYWORDS argument, procedure '\" Local Variables: '\" mode: nroff '\" End: Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -17,10 +17,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" +#include "tclCompile.h" +#include "tclOOInt.h" /* * During execution of the "lsort" command, structures of the following type * are used to arrange the objects being sorted into a collection of linked * lists. @@ -106,10 +108,12 @@ static int DictionaryCompare(const char *left, const char *right); static Tcl_NRPostProc IfConditionCallback; static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int InfoArgSpecCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int InfoBodyCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoCmdCountCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoCommandsCmd(ClientData dummy, Tcl_Interp *interp, @@ -159,10 +163,11 @@ * "info" command. */ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"argspec", InfoArgSpecCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, @@ -512,10 +517,279 @@ } } Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * InfoArgSpecCmd -- + * + * Called to implement the "info argspec" command that returns the + * extendend argument specification for a procedure. + * Handles the following syntaxes: + * + * info argspec proc procName ?arg? + * info argspec lambda lambdaTerm ?arg? + * info argspec constructor className ?arg? + * info argspec method className methodName ?arg? + * info argspec objmethod object methodName ?arg? + * info argspec specifiers + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoArgSpecCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const types[] = { + "proc", "lambda", "constructor", "method", "objmethod", + "specifiers", NULL, + }; + static const char *const specifiers[] = { + /* supported specifiers, must be ordered */ + "-default", "-name", "-required", "-switch", "-upvar", NULL + }; + enum Types { + ARGSPEC_PROC, ARGSPEC_LAMBDA, ARGSPEC_CONSTRUCTOR, ARGSPEC_METHOD, + ARGSPEC_OBJMETHOD, ARGSPEC_SPECIFIERS + }; + register Interp *iPtr = (Interp *) interp; + const char *procName = NULL, *argName = NULL; + Proc *procPtr = NULL; + CompiledLocal *localPtr; + Tcl_Obj *listObjPtr; + Object *oPtr; + Method *methodPtr; + Tcl_HashEntry *hPtr; + int idx, result; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "type ..."); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK) { + return TCL_ERROR; + } + + switch ((enum Types) idx) { + case ARGSPEC_PROC: + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "proc procname ?arg?"); + return TCL_ERROR; + } + + procName = TclGetString(objv[2]); + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't a procedure", procName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROCEDURE", procName, + NULL); + return TCL_ERROR; + } + + argName = (objc == 4) ? TclGetString(objv[3]) : NULL; + break; + + case ARGSPEC_LAMBDA: + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "lambda lambdaTerm ?arg?"); + return TCL_ERROR; + } + + if (objv[2]->typePtr == &tclLambdaType) { + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { + result = tclLambdaType.setFromAnyProc(interp, objv[2]); + if (result != TCL_OK) { + return result; + } + procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + } + + procName = "lambdaTerm"; + argName = (objc == 4) ? TclGetString(objv[3]) : NULL; + break; + + case ARGSPEC_CONSTRUCTOR: + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "constructor className ?arg?"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + methodPtr = oPtr->classPtr->constructorPtr; + if (methodPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" has no defined constructor", + TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ARGSPEC", + "CONSRUCTOR", NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(methodPtr); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of constructor", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ARGSPEC", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + procName = "constructor"; + argName = (objc == 4) ? TclGetString(objv[3]) : NULL; + break; + + case ARGSPEC_METHOD: + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, + "method className methodName ?arg?"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->classPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" is not a class", TclGetString(objv[2]))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } + + procName = TclGetString(objv[3]); + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) objv[3]); + if (hPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", procName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); + return TCL_ERROR; + } + procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ARGSPEC", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + argName = (objc == 5) ? TclGetString(objv[4]) : NULL; + break; + + case ARGSPEC_OBJMETHOD: + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, + "objmethod object methodName ?arg?"); + return TCL_ERROR; + } + + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (oPtr->methodsPtr == NULL) { + hPtr = NULL; + } else { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[3]); + } + + procName = TclGetString(objv[3]); + if (hPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown method \"%s\"", procName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); + return TCL_ERROR; + } + + procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); + if (procPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "body not available for this kind of method", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ARGSPEC", + "METHODTYPE", NULL); + return TCL_ERROR; + } + + argName = (objc == 5) ? TclGetString(objv[4]) : NULL; + break; + + case ARGSPEC_SPECIFIERS: + listObjPtr = Tcl_NewListObj(0, NULL); + for (idx = 0; specifiers[idx] != NULL; idx++) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(specifiers[idx], -1)); + } + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; + break; + } + + if (argName == NULL) { + /* info argspec ... procName */ + listObjPtr = Tcl_NewListObj(0, NULL); + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + TclProcGetArgSpec(interp, localPtr, + TCL_GETARGSPEC_WITH_NAME)); + } + } + + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; + } + + /* info argspec ... procName arg */ + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (TclIsVarArgument(localPtr) + && (strcmp(argName, localPtr->name) == 0)) { + listObjPtr = TclProcGetArgSpec(interp, localPtr, 0); + Tcl_SetObjResult(interp, listObjPtr); + return TCL_OK; + } + } + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s \"%s\" doesn't have an argument \"%s\"", + Tcl_GetString(objv[1]), procName, argName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- * * InfoBodyCmd -- Index: generic/tclCompile.c ================================================================== --- generic/tclCompile.c +++ generic/tclCompile.c @@ -3030,10 +3030,11 @@ if (name == NULL) { localPtr->flags |= VAR_TEMPORARY; } localPtr->defValuePtr = NULL; localPtr->resolveInfo = NULL; + localPtr->argSpecPtr = NULL; if (name != NULL) { memcpy(localPtr->name, name, (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -696,10 +696,17 @@ * name. * VAR_RESOLVED - 1 if name resolution has been done for this * variable. * VAR_IS_ARGS 1 if this variable is the last argument and is * named "args". + * VAR_NAMED_GROUP 1 means that this argument is part of a named + * group defined using an extended argument + * specification. + * VAR_ARG_UPVAR 1 means that this argument has been defined + * using the -upvar extended arg specification. + * VAR_ARG_OPTIONAL 1 means that this argument is not required to + * be specified on call-site. */ /* * FLAGS RENUMBERED: everything breaks already, make things simpler. * @@ -737,10 +744,13 @@ /* Special handling on initialisation (only CompiledLocal). */ #define VAR_ARGUMENT 0x100 /* KEEP OLD VALUE! See tclProc.c */ #define VAR_TEMPORARY 0x200 /* KEEP OLD VALUE! See tclProc.c */ #define VAR_IS_ARGS 0x400 #define VAR_RESOLVED 0x8000 +#define VAR_NAMED_GROUP 0x10000 +#define VAR_ARG_UPVAR 0x20000 +#define VAR_ARG_OPTIONAL 0x40000 /* * Macros to ensure that various flag bits are set properly for variables. * The ANSI C "prototypes" for these macros are: * @@ -843,10 +853,13 @@ ((varPtr)->flags & VAR_IN_HASHTABLE) #define TclIsVarDeadHash(varPtr) \ ((varPtr)->flags & VAR_DEAD_HASH) +#define TclIsVarWithExtArgs(varPtr) \ + ((varPtr)->flags & (VAR_NAMED_GROUP|VAR_ARG_UPVAR|VAR_ARG_OPTIONAL)) + #define TclGetVarNsPtr(varPtr) \ (TclIsVarInHash(varPtr) \ ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \ : NULL) @@ -891,13 +904,65 @@ */ /* * Forward declaration to prevent an error when the forward reference to * Command is encountered in the Proc and ImportRef types declared below. + * Same for CompiledLocal in the NamedGroupEntry type. */ struct Command; +struct CompiledLocal; + +/* + * The variable-length structure below describes an entry in a group of + * named parameter defined together. + */ + +typedef struct NamedGroupEntry { + struct NamedGroupEntry *nextPtr; + /* Next entry in the named-group, or NULL if + * this is the last entry. */ + int nameLength; /* The number of characters in entry's name */ + int localIndex; /* Index of the related local in the array of + * compiler-assigned variables in the procedure + * call frame. */ + Tcl_Obj *valuePtr; /* Pointer to the default value of the named + * parameter, used with the -switch argument + * specifier. NULL if it is related to a named + * parameter created with the -name argument + * specifier. */ + struct CompiledLocal *localPtr; + /* Pointer to the related local in the linked + * list of locals for the procedure. */ + char name[1]; /* Name of the entry starts here. The actual + * size of this field will be large enough to + * hold the name. MUST BE THE LAST FIELD IN + * THE STRUCTURE! */ +} NamedGroupEntry; + +/* + * The structure below describes an extended argument specification applied + * on a proc argument (see TIP#457). + */ + +typedef struct ExtendedArgSpec { + struct NamedGroupEntry *firstNamedEntryPtr; + /* Pointer to the first named parameter entry + * defined on this proc argument. */ + 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. */ + int remainAfterNamedGroup; /* If the number of arguments after a named + * group is fixed and non-optional, this will + * contain that number. Otherwise, will be set + * to -1. This 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; /* * The variable-length structure below describes a local variable of a * procedure that was recognized by the compiler. These variables have a name, * an element in the array of compiler-assigned local variables in the @@ -921,11 +986,12 @@ int frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, * although only VAR_ARGUMENT, VAR_TEMPORARY, - * and VAR_RESOLVED make sense. */ + * VAR_RESOLVED, VAR_NAMED_GROUP and VAR_ARG_* + * make sense. */ Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ Tcl_ResolvedVarInfo *resolveInfo; /* Customized variable resolution info @@ -932,10 +998,13 @@ * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable * is marked by a unique ClientData tag during * compilation, and that same tag is used to * find the variable at runtime. */ + ExtendedArgSpec *argSpecPtr; + /* Extended argument specification if this is + * a proc argument defined using one. */ char name[1]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large * enough to hold the name. MUST BE THE LAST * FIELD IN THE STRUCTURE! */ @@ -963,10 +1032,11 @@ * procedure's body command. */ int numArgs; /* Number of formal parameters. */ int numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments and * temporaries. */ + int flags; /* Various flag bits. See below. */ CompiledLocal *firstLocalPtr; /* Pointer to first of the procedure's * compiler-allocated local variables, or NULL * if none. The first numArgs entries in this * list describe the procedure's formal @@ -974,10 +1044,23 @@ CompiledLocal *lastLocalPtr;/* Pointer to the last allocated local * variable or NULL if none. This has frame * index (numCompiledLocals-1). */ } Proc; +/* + * Flag bits for procedures. + * + * PROC_HAS_EXT_ARG_SPEC 1 means that the procedure has at least one + * argument defined using an extended argument + * specification. + * PROC_HAS_NAMED_GROUP 1 means that the procedure has at least one + * named group. + */ + +#define PROC_HAS_EXT_ARG_SPEC 0x01 +#define PROC_HAS_NAMED_GROUP 0x02 + /* * The type of functions called to process errors found during the execution * of a procedure (or lambda term or ...). */ @@ -2858,10 +2941,19 @@ #define TCL_DD_STEELE0 0x1 /* 'Steele&White' after masking */ #define TCL_DD_SHORTEST0 0x0 /* 'Shortest possible' after masking */ +/* Flags for TclProcGetArgSpec */ + +#define TCL_GETARGSPEC_WITH_NAME 0x01 + /* Include arg name before specification */ +#define TCL_GETARGSPEC_TRY_OLDSTYLE 0x02 + /* Return argument spec using old-style + * specification if there is no other options + * set on argument */ + /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ @@ -3065,10 +3157,12 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, int numBytes, Tcl_Parse *parsePtr); MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); +MODULE_SCOPE Tcl_Obj * TclProcGetArgSpec(Tcl_Interp *interp, + CompiledLocal *argPtr, int flags); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, int len); @@ -3178,10 +3272,13 @@ int *clNextOuter, const char *outerScript); MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE int TclUpvarForExtArg(Tcl_Interp *interp, + 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); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, Index: generic/tclOO.c ================================================================== --- generic/tclOO.c +++ generic/tclOO.c @@ -184,12 +184,11 @@ static const char *clonedBody = "foreach p [info procs [info object namespace $originObject]::*] {" " set args [info args $p];" " set idx -1;" " foreach a $args {" -" lset args [incr idx] " -" [if {[info default $p $a d]} {list $a $d} {list $a}]" +" lset args [incr idx] [concat $a [info argspec proc $p $a]]" " };" " set b [info body $p];" " set p [namespace tail $p];" " proc $p $args $b;" "};" Index: generic/tclOOInfo.c ================================================================== --- generic/tclOOInfo.c +++ generic/tclOOInfo.c @@ -266,18 +266,13 @@ resultObjs[0] = Tcl_NewObj(); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - argObj = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } + Tcl_Obj *argObj = TclProcGetArgSpec(interp, localPtr, + TCL_GETARGSPEC_WITH_NAME|TCL_GETARGSPEC_TRY_OLDSTYLE); + Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); @@ -856,18 +851,13 @@ resultObjs[0] = Tcl_NewObj(); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - argObj = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } + Tcl_Obj *argObj = TclProcGetArgSpec(interp, localPtr, + TCL_GETARGSPEC_WITH_NAME|TCL_GETARGSPEC_TRY_OLDSTYLE); + Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } resultObjs[1] = TclOOGetMethodBody(clsPtr->constructorPtr); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); @@ -924,18 +914,13 @@ resultObjs[0] = Tcl_NewObj(); for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj; - - argObj = Tcl_NewObj(); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } + Tcl_Obj *argObj = TclProcGetArgSpec(interp, localPtr, + TCL_GETARGSPEC_WITH_NAME|TCL_GETARGSPEC_TRY_OLDSTYLE); + Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj); } } resultObjs[1] = TclOOGetMethodBody(Tcl_GetHashValue(hPtr)); Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs)); Index: generic/tclOOMethod.c ================================================================== --- generic/tclOOMethod.c +++ generic/tclOOMethod.c @@ -1295,17 +1295,13 @@ argsObj = Tcl_NewObj(); for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { - Tcl_Obj *argObj = Tcl_NewObj(); + Tcl_Obj *argObj = TclProcGetArgSpec(interp, localPtr, + TCL_GETARGSPEC_WITH_NAME|TCL_GETARGSPEC_TRY_OLDSTYLE); - Tcl_ListObjAppendElement(NULL, argObj, - Tcl_NewStringObj(localPtr->name, -1)); - if (localPtr->defValuePtr != NULL) { - Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); - } Tcl_ListObjAppendElement(NULL, argsObj, argObj); } } /* Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -33,10 +33,13 @@ static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); static int InitArgsAndLocals(Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip); +static int InitArgsWithOptions(Tcl_Interp *interp, + Tcl_Obj *procNameObj, Tcl_Obj *const *argObjs, + int numArgs); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); @@ -45,10 +48,20 @@ static void MakeProcError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void MakeLambdaError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static int ProcAddNamedGroupEntry(Tcl_Interp *interp, + CompiledLocal *localPtr, const char *argName, + Tcl_Obj *valuePtr, NamedGroupEntry **lastEntryPtr, + Tcl_HashTable **namedHashPtrPtr); +static int ProcParseArgSpec(Tcl_Interp *interp, + const char *argSpec, int argIdx, int isLastArg, + CompiledLocal **localPtrPtr, + Tcl_HashTable **namedHashPtrPtr); +static inline int ProcCheckScalarArg(const char *arg, const char **err); +static void ProcCompiledLocalsFree(CompiledLocal *localPtr); static Tcl_NRPostProc ApplyNR2; static Tcl_NRPostProc InterpProcNR2; static Tcl_NRPostProc Uplevel_Callback; @@ -395,14 +408,15 @@ Interp *iPtr = (Interp *) interp; const char **argArray = NULL; register Proc *procPtr; int i, length, result, numArgs; - const char *args, *bytes, *p; + const char *args, *bytes; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + CompiledLocal *newLocalPtr; int precompiled = 0; + Tcl_HashTable *hPtr = NULL; if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to @@ -462,10 +476,11 @@ procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; procPtr->numArgs = 0; /* Actual argument count is set below. */ procPtr->numCompiledLocals = 0; + procPtr->flags = 0; procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; } /* @@ -498,82 +513,20 @@ procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength; - size_t valueLength; - const char **fieldValues; - - /* - * Now divide the specifier up into name and default. - */ - - result = Tcl_SplitList(interp, argArray[i], &fieldCount, - &fieldValues); + + result = ProcParseArgSpec(interp, argArray[i], i, (i == numArgs - 1), + &newLocalPtr, &hPtr); 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])); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); - goto procError; - } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "argument with no name", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); - goto procError; - } - - nameLength = strlen(fieldValues[0]); - if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); - } else { - valueLength = 0; - } - - /* - * 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. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); - 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); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", NULL); - goto procError; - } - p++; - } if (precompiled) { + Tcl_Obj *argSpec1, *argSpec2; + /* * Compare the parsed argument with the stored one. Note that the * only flag value that makes sense at this point is VAR_ARGUMENT * (its value was kept the same as pre VarReform to simplify * tbcload's processing of older byetcodes). @@ -581,89 +534,102 @@ * The only other flag vlaue that is important to retrieve from * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ - if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) - || (localPtr->frameIndex != i) - || !(localPtr->flags & VAR_ARGUMENT) - || (localPtr->defValuePtr == NULL && fieldCount == 2) - || (localPtr->defValuePtr != NULL && fieldCount != 2)) { + if ((localPtr->nameLength != newLocalPtr->nameLength) + || (strcmp(localPtr->name, newLocalPtr->name)) + || (localPtr->frameIndex != newLocalPtr->frameIndex) + || !(localPtr->flags & VAR_ARGUMENT)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); + ProcCompiledLocalsFree(newLocalPtr); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); + goto procError; + } + + /* + * Compare the argument specification. + */ + + argSpec1 = TclProcGetArgSpec(interp, localPtr, 0); + argSpec2 = TclProcGetArgSpec(interp, newLocalPtr, 0); + if (strcmp(Tcl_GetString(argSpec1), Tcl_GetString(argSpec2)) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"%s\" has " + "argument spec inconsistent with precompiled body", + procName, newLocalPtr->name)); + ProcCompiledLocalsFree(newLocalPtr); + Tcl_DecrRefCount(argSpec1); + Tcl_DecrRefCount(argSpec2); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } - /* - * Compare the default value if any. - */ - - if (localPtr->defValuePtr != NULL) { - const char *tmpPtr = TclGetString(localPtr->defValuePtr); - 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_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", NULL); - goto procError; - } - } if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } + Tcl_DecrRefCount(argSpec1); + Tcl_DecrRefCount(argSpec2); + ProcCompiledLocalsFree(newLocalPtr); localPtr = localPtr->nextPtr; } else { - /* - * Allocate an entry in the runtime procedure frame's array of - * local variables for the argument. - */ - - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); if (procPtr->firstLocalPtr == NULL) { - procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; - } else { - procPtr->lastLocalPtr->nextPtr = localPtr; - procPtr->lastLocalPtr = localPtr; - } - localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; - localPtr->frameIndex = i; - localPtr->flags = VAR_ARGUMENT; - localPtr->resolveInfo = NULL; - - if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); - Tcl_IncrRefCount(localPtr->defValuePtr); - } else { - localPtr->defValuePtr = NULL; - } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); - if ((i == numArgs - 1) - && (localPtr->nameLength == 4) - && (localPtr->name[0] == 'a') - && (strcmp(localPtr->name, "args") == 0)) { - localPtr->flags |= VAR_IS_ARGS; - } - } - - ckfree(fieldValues); + procPtr->firstLocalPtr = newLocalPtr; + } else { + procPtr->lastLocalPtr->nextPtr = newLocalPtr; + } + procPtr->lastLocalPtr = newLocalPtr; + + if (TclIsVarWithExtArgs(newLocalPtr)) { + procPtr->flags |= PROC_HAS_EXT_ARG_SPEC; + if (newLocalPtr->flags & VAR_NAMED_GROUP) { + procPtr->flags |= PROC_HAS_NAMED_GROUP; + } + } + } + } + + if ((procPtr->flags & PROC_HAS_NAMED_GROUP) + && !(procPtr->lastLocalPtr->flags & (VAR_IS_ARGS|VAR_ARG_OPTIONAL)) + && (procPtr->lastLocalPtr->defValuePtr == NULL)) { + + /* proc with at least one named group and a non-optional and non-args + * last variable. Find and store the number of arguments after the + * last named group, this will be used to end the named group handling + * and ensure the last input arguments can be assigned. + */ + + CompiledLocal *lastNamedGroupPtr = NULL; + for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if ((localPtr->argSpecPtr != NULL) + && (localPtr->argSpecPtr->namedHashTable != NULL)) { + lastNamedGroupPtr = localPtr; + } + } + + /* find last entry of the named group */ + for (localPtr = lastNamedGroupPtr; localPtr != NULL; + localPtr = localPtr->nextPtr) { + if ((localPtr->nextPtr == NULL) + || !(localPtr->nextPtr->flags & VAR_NAMED_GROUP)) { + break; + } + } + + if (localPtr != NULL) { + lastNamedGroupPtr->argSpecPtr->remainAfterNamedGroup = + procPtr->lastLocalPtr->frameIndex - localPtr->frameIndex; + } } *procPtrPtr = procPtr; ckfree(argArray); return TCL_OK; @@ -671,28 +637,505 @@ procError: if (precompiled) { procPtr->refCount--; } else { Tcl_DecrRefCount(bodyPtr); - while (procPtr->firstLocalPtr != NULL) { - localPtr = procPtr->firstLocalPtr; - procPtr->firstLocalPtr = localPtr->nextPtr; - - defPtr = localPtr->defValuePtr; - if (defPtr != NULL) { - Tcl_DecrRefCount(defPtr); - } - - ckfree(localPtr); - } + ProcCompiledLocalsFree(procPtr->firstLocalPtr); ckfree(procPtr); } if (argArray != NULL) { ckfree(argArray); } return TCL_ERROR; } + +/* + *---------------------------------------------------------------------- + * + * ProcCheckScalarArg -- + * + * Check that the argument name is a scalar. + * + * Results: + * Returns TCL_OK if argument is a scalar. Returns TCL_ERROR and + * set |err| with an error description if it is not a scalar. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static inline int +ProcCheckScalarArg( + const char *arg, /* Argument name. */ + const char **err) /* Error description (output) */ +{ + const char *p = arg; + + /* + * Check that the formal parameter name is a scalar. + */ + + while (*p != '\0') { + if (*p == '(') { + const char *q = p; + do { + q++; + } while (*q != '\0'); + q--; + if (*q == ')') { /* We have an array element. */ + *err = "is an array element"; + return TCL_ERROR; + } + } else if ((*p == ':') && (*(p+1) == ':')) { + *err = "is not a simple name"; + return TCL_ERROR; + } + p++; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ProcAddNamedGroupEntry -- + * + * Create a NamedGroupEntry for a specific CompiledLocal object. + * NamedGroupEntry are created for each name defined using -name + * or -switch argument specifier. In the later case, a value is + * also associated with the name. + * A Tcl_HashTable object is shared between all contiguous named + * parameters, it is created when parsing the first entry. + * + * Results: + * Returns TCL_OK on success and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If anything goes wrong, this function returns an error message in the + * interpreter. On success, memory is allocated and linked into the + * ExtendedArgSpec structure. A Tcl_HashTable is allocated when + * parsing the first entry of a named group entry. The variable pointed + * by lastEntryPtr will be updated to always contain the pointer + * of the last entry. + * + *---------------------------------------------------------------------- + */ + +static int +ProcAddNamedGroupEntry( + Tcl_Interp *interp, /* Interpreter containing proc. */ + CompiledLocal *localPtr, /* Related CompiledLocal */ + const char *argName, /* Name string to add */ + Tcl_Obj *valuePtr, /* Value to add when related to a -switch + * argspec (NULL for -name argspec) */ + NamedGroupEntry **lastEntryPtr, + /* Pointer to a variable which contain the current + * last named entry for this local. */ + Tcl_HashTable **namedHashPtrPtr) + /* Shared Tcl_HashTable created on the first + * named parameter entry to speedup lookups + * of named parameters. */ +{ + NamedGroupEntry *entryPtr; + ExtendedArgSpec *argSpecPtr = localPtr->argSpecPtr; + int length = strlen(argName), isNew; + Tcl_HashEntry *hPtr; + Tcl_HashTable *namedHashPtr; + + /* + * Check that the name is not empty, does not contain a space or has + * not already been added. + */ + + if (length == 0) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "named argument with no name", -1)); + return TCL_ERROR; + } else if (strchr(argName, ' ') != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "named argument \"%s\" with unexpected space character", + argName)); + return TCL_ERROR; + } else if ((*namedHashPtrPtr != NULL) + && (Tcl_FindHashEntry(*namedHashPtrPtr, argName) != NULL)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "named argument \"%s\" has been used more than once " + "in the same named group", argName)); + return TCL_ERROR; + } + + entryPtr = ckalloc(TclOffset(NamedGroupEntry, name) + length+1); + entryPtr->nextPtr = NULL; + entryPtr->nameLength = length; + entryPtr->localIndex = localPtr->frameIndex; + entryPtr->localPtr = localPtr; + entryPtr->valuePtr = valuePtr; + memcpy(entryPtr->name, argName, length+1); + if (entryPtr->valuePtr != NULL) { + Tcl_IncrRefCount(entryPtr->valuePtr); + } + + if (argSpecPtr->firstNamedEntryPtr == NULL) { + argSpecPtr->firstNamedEntryPtr = entryPtr; + } else { + (*lastEntryPtr)->nextPtr = entryPtr; + } + *lastEntryPtr = entryPtr; + + /* Either use existing hash table or create a new one */ + + if (*namedHashPtrPtr != NULL) { + namedHashPtr = *namedHashPtrPtr; + } + else { + namedHashPtr = ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(namedHashPtr, TCL_STRING_KEYS); + + argSpecPtr->namedHashTable = namedHashPtr; + *namedHashPtrPtr = namedHashPtr; + } + + hPtr = Tcl_CreateHashEntry(namedHashPtr, argName, &isNew); + Tcl_SetHashValue(hPtr, entryPtr); + + localPtr->flags |= VAR_NAMED_GROUP; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ProcParseArgSpec -- + * + * Given an argument specification defined either using old-style + * (arg ?default?) or extended argument specification (TIP#457), + * create and initialize the related CompiledLocal entry. + * + * Results: + * Returns TCL_OK on success, along with a pointer to the created + * 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 + * is allocated when parsing the first entry of a named group entry. + * + *---------------------------------------------------------------------- + */ + +static int +ProcParseArgSpec( + Tcl_Interp *interp, /* Interpreter containing proc. */ + const char *argSpec, /* Argument specification. */ + int argIdx, /* Argument index in the array of variables + * in the procedure call frame. */ + int isLastArg, /* != 0 means this is the last argument. */ + CompiledLocal **localPtrPtr, + /* On success, store the 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; + ExtendedArgSpec *argSpecPtr; + NamedGroupEntry *lastNamedEntryPtr = NULL; + const char **fieldValues = NULL; + int fieldCount, length; + const char *err; + int required = -1, hasSwitch = 0; + int result, i, j; + + /* + * Divide the argument specifier into a list. + */ + + result = Tcl_SplitList(interp, argSpec, &fieldCount, &fieldValues); + if (result != TCL_OK) { + goto parseError; + } + + if ((fieldCount > 2) && (fieldCount % 2 != 1)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unexpected fields number in argument specifier \"%s\"", + argSpec)); + goto parseError; + } else if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument with no name", -1)); + goto parseError; + } + + /* + * Check that the formal parameter name is a scalar. + */ + + if (ProcCheckScalarArg(fieldValues[0], &err) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "formal parameter \"%s\" %s", fieldValues[0], err)); + goto parseError; + } + + length = strlen(fieldValues[0]); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + length+1); + localPtr->nextPtr = NULL; + localPtr->nameLength = length; + localPtr->frameIndex = argIdx; + localPtr->flags = VAR_ARGUMENT; + localPtr->defValuePtr = NULL; + localPtr->resolveInfo = NULL; + localPtr->argSpecPtr = NULL; + memcpy(localPtr->name, fieldValues[0], length+1); + + if ((isLastArg != 0) + && (localPtr->nameLength == 4) + && (localPtr->name[0] == 'a') + && (strcmp(localPtr->name, "args") == 0)) { + localPtr->flags |= VAR_IS_ARGS; + } + + if (fieldCount <= 2) { + /* old-style argument specification (arg ?default?) */ + + if (fieldCount == 2) { + localPtr->defValuePtr = Tcl_NewStringObj(fieldValues[1], -1); + Tcl_IncrRefCount(localPtr->defValuePtr); + } + + *localPtrPtr = localPtr; + *namedHashPtrPtr = NULL; + ckfree(fieldValues); + return TCL_OK; + } + + /* + * Check and handle each extended argument specification. + */ + + argSpecPtr = ckalloc(sizeof(ExtendedArgSpec)); + argSpecPtr->firstNamedEntryPtr = NULL; + argSpecPtr->namedHashTable = NULL; + argSpecPtr->remainAfterNamedGroup = -1; + argSpecPtr->upvarLevelPtr = NULL; + localPtr->argSpecPtr = argSpecPtr; + + for (i = 1 ; i < fieldCount ; i += 2) { + length = strlen(fieldValues[i]); + + if (*fieldValues[i] != '-') { + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown argument option \"%s\" or " + "too many fields in argument specifier \"%s\"", + fieldValues[i], argSpec)); + goto parseError; + + } else if ((length == 8) + && (strcmp(fieldValues[i], "-default") == 0)) { + + /* + * Handle '-default ', keep value in localPtr->defValuePtr. + */ + + if (localPtr->defValuePtr != NULL) { + Tcl_DecrRefCount(localPtr->defValuePtr); + } + localPtr->defValuePtr = Tcl_NewStringObj(fieldValues[i+1], -1); + Tcl_IncrRefCount(localPtr->defValuePtr); + + } else if ((length == 5) + && (strcmp(fieldValues[i], "-name") == 0)) { + + /* + * Handle '-name name', this create a name group if not + * already created. + */ + + int nameCount; + const char **nameValues; + + result = Tcl_SplitList(interp, fieldValues[i+1], &nameCount, + &nameValues); + if (result != TCL_OK) { + goto parseError; + } + + for (j = 0; j < nameCount; j++) { + result = ProcAddNamedGroupEntry(interp, localPtr, + nameValues[j], NULL, &lastNamedEntryPtr, namedHashPtrPtr); + if (result != TCL_OK) { + ckfree(nameValues); + goto parseError; + } + } + + ckfree(nameValues); + + } else if ((length == 7) + && (strcmp(fieldValues[i], "-switch") == 0)) { + + /* + * Handle '-switch switch', this create a name group (with a value) + * if not already created. + */ + + int swCount, swEntCount; + const char **swValues, **swEntValues; + + result = Tcl_SplitList(interp, fieldValues[i+1], &swCount, + &swValues); + if (result != TCL_OK) { + goto parseError; + } + + for (j = 0; j < swCount; j++) { + result = Tcl_SplitList(interp, swValues[j], &swEntCount, + &swEntValues); + if (result != TCL_OK) { + ckfree(swValues); + goto parseError; + } + + if (swEntCount == 1) { + /* one field, use switch name as value */ + result = ProcAddNamedGroupEntry(interp, localPtr, + swEntValues[0], Tcl_NewStringObj(swEntValues[0], -1), + &lastNamedEntryPtr, namedHashPtrPtr); + } else if (swEntCount == 2) { + /* two fields, use second one as value */ + result = ProcAddNamedGroupEntry(interp, localPtr, + swEntValues[0], Tcl_NewStringObj(swEntValues[1], -1), + &lastNamedEntryPtr, namedHashPtrPtr); + } else { + /* invalid number of fields */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "incorrect switch value \"%s\"", swValues[j])); + result = TCL_ERROR; + } + ckfree(swEntValues); + + if (result != TCL_OK) { + ckfree(swValues); + goto parseError; + } + } + + hasSwitch = 1; + ckfree(swValues); + + } else if ((length == 6) + && (strcmp(fieldValues[i], "-upvar") == 0)) { + + /* + * Handle '-upvar level', set upvarLevelPtr and VAR_ARG_UPVAR + * flag. + */ + + const char *levelStr = fieldValues[i+1]; + int level; + + if (Tcl_GetInt(NULL, (*levelStr == '#') ? levelStr+1 : levelStr, + &level) != TCL_OK || level < 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Invalid level \"%s\" for -upvar arg specifier", + levelStr)); + goto parseError; + } + + if (argSpecPtr->upvarLevelPtr != NULL) { + Tcl_DecrRefCount(argSpecPtr->upvarLevelPtr); + } + argSpecPtr->upvarLevelPtr = Tcl_NewStringObj(levelStr, -1); + Tcl_IncrRefCount(argSpecPtr->upvarLevelPtr); + localPtr->flags |= VAR_ARG_UPVAR; + + } else if ((length == 9) + && (strcmp(fieldValues[i], "-required") == 0)) { + + /* + * Handle '-required bool', set required var which will be used + * 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); + TclDecrRefCount(boolObj); + + if (result != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Invalid boolean \"%s\" for -required arg specifier", + fieldValues[i+1])); + goto parseError; + } else if (boolVal) { + required = 1; + } else { + required = 0; + } + + } else { + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown argument option \"%s\" or " + "too many fields in argument specifier \"%s\"", + fieldValues[i], argSpec)); + goto parseError; + + } + } + + if (hasSwitch) { + if (localPtr->flags & VAR_ARG_UPVAR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-upvar can't be used with -switch", -1)); + goto parseError; + } + } + + if ((required == 1) && (localPtr->defValuePtr)) { + /* '-required 1' explicitely set, remove the default value to + * enforce the requirement. */ + Tcl_DecrRefCount(localPtr->defValuePtr); + localPtr->defValuePtr = NULL; + } 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 '-required' specifier + * has been used. */ + localPtr->flags |= VAR_ARG_OPTIONAL; + } + + if ((*namedHashPtrPtr != NULL) && !(localPtr->flags & VAR_NAMED_GROUP)) { + /* Not part of a named group anymore, unset current named hash table */ + *namedHashPtrPtr = NULL; + } + + *localPtrPtr = localPtr; + ckfree(fieldValues); + return TCL_OK; + +parseError: + if (localPtr != NULL) { + ProcCompiledLocalsFree(localPtr); + } + if (fieldValues) { + ckfree(fieldValues); + } + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- * * TclGetFrame -- @@ -1071,11 +1514,11 @@ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; register Proc *procPtr = framePtr->procPtr; register Var *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, i; - Tcl_Obj **desiredObjs; + Tcl_Obj **desiredObjs, *argObj, *finalObj = NULL; const char *final = NULL; /* * Build up desired argument list for Tcl_WrongNumArgs */ @@ -1093,35 +1536,94 @@ desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); #endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); - defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); - for (i=1 ; i<=numArgs ; i++, defPtr++) { - Tcl_Obj *argObj; - Tcl_Obj *namePtr = localName(framePtr, i-1); - - if (defPtr->value.objPtr != NULL) { - TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL); - } else if (defPtr->flags & VAR_IS_ARGS) { - numArgs--; - final = "?arg ...?"; - break; - } else { - argObj = namePtr; - Tcl_IncrRefCount(namePtr); - } - desiredObjs[i] = argObj; + if (procPtr->flags & PROC_HAS_EXT_ARG_SPEC) { + CompiledLocal *localPtr; + int first = 1; + + TclNewObj(finalObj); + numArgs = 0; + for (localPtr = procPtr->firstLocalPtr; + localPtr != NULL; + localPtr = localPtr->nextPtr) { + if (!TclIsVarArgument(localPtr)) { + continue; + } else if (localPtr->flags & VAR_IS_ARGS) { + argObj = Tcl_NewStringObj("?arg ...?", -1); + } else if ((localPtr->argSpecPtr != NULL) + && (localPtr->argSpecPtr->firstNamedEntryPtr != NULL)) { + NamedGroupEntry *namedGroupPtr; + TclNewObj(argObj); + for (namedGroupPtr = localPtr->argSpecPtr->firstNamedEntryPtr; + namedGroupPtr != NULL; + namedGroupPtr = namedGroupPtr->nextPtr) { + Tcl_AppendStringsToObj(argObj, "|-", namedGroupPtr->name, + NULL); + if (localPtr->flags & VAR_ARG_UPVAR) { + Tcl_AppendStringsToObj(argObj, + " &", localPtr->name, "&", NULL); + } else if (namedGroupPtr->valuePtr == NULL) { + Tcl_AppendStringsToObj(argObj, " ", localPtr->name, + NULL); + } + } + Tcl_AppendStringsToObj(argObj, "|", NULL); + } else { + if (localPtr->flags & VAR_ARG_UPVAR) { + TclNewObj(argObj); + Tcl_AppendStringsToObj(argObj, + "&", localPtr->name, "&", NULL); + } else { + argObj = Tcl_NewStringObj(localPtr->name, + localPtr->nameLength); + } + } + + if ((localPtr->defValuePtr != NULL) + || (localPtr->flags & VAR_ARG_OPTIONAL)) { + Tcl_AppendStringsToObj(finalObj, first ? "?" : " ?", + Tcl_GetString(argObj), "?", NULL); + } else { + Tcl_AppendStringsToObj(finalObj, first ? "" : " ", + Tcl_GetString(argObj), NULL); + } + first = 0; + Tcl_DecrRefCount(argObj); + } + final = Tcl_GetString(finalObj); + } else { + defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + for (i=1 ; i<=numArgs ; i++, defPtr++) { + Tcl_Obj *namePtr = localName(framePtr, i-1); + + if (defPtr->value.objPtr != NULL) { + TclNewObj(argObj); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), + "?", NULL); + } else if (defPtr->flags & VAR_IS_ARGS) { + numArgs--; + final = "?arg ...?"; + break; + } else { + argObj = namePtr; + Tcl_IncrRefCount(namePtr); + } + desiredObjs[i] = argObj; + } } Tcl_ResetResult(interp); Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); for (i=0 ; i<=numArgs ; i++) { Tcl_DecrRefCount(desiredObjs[i]); } + if (finalObj != NULL) { + Tcl_DecrRefCount(finalObj); + } TclStackFree(interp, desiredObjs); return TCL_ERROR; } /* @@ -1446,10 +1948,24 @@ goto incorrectArgs; } else { goto correctArgs; } } + + if ((procPtr->flags & PROC_HAS_EXT_ARG_SPEC) != 0) { + int result; + + memset(varPtr, 0, numArgs*sizeof(Var)); + result = InitArgsWithOptions(interp, procNameObj, argObjs, argCt); + varPtr += numArgs; + if (result != TCL_OK) { + goto incorrectArgs; + } else { + goto correctArgs; + } + } + imax = ((argCt < numArgs-1) ? argCt : numArgs-1); for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { /* * "Normal" arguments; last formal is special, depends on it being * 'args'. @@ -1531,10 +2047,335 @@ } memset(varPtr, 0, ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); return ProcWrongNumArgs(interp, skip); } + +/* + *---------------------------------------------------------------------- + * + * InitArgsWithOptions -- + * + * This routine is invoked in order to initialize the arguments + * for a new call frame for a proc with extended arguments + * specification. The numArgs variables in the array of local + * variables must be initialized prior to calling this function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The numArgs variables inside the array of local variables + * can be initialized with object references, even if an error + * is returned. + * + *---------------------------------------------------------------------- + */ + +static int +InitArgsWithOptions( + register Tcl_Interp *interp,/* Interpreter in which procedure was + * invoked. */ + Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ + Tcl_Obj *const *argObjs, /* Array of input arguments */ + int argCt) /* Number of input arguments */ +{ + CallFrame *framePtr = ((Interp *)interp)->varFramePtr; + register Proc *procPtr = framePtr->procPtr; + register Var *varPtr = framePtr->compiledLocals, *localVarPtr; + int numArgs = procPtr->numArgs, iLocal, iArg; + Tcl_Obj *objPtr; + CompiledLocal *localPtr; + NamedGroupEntry *namedGroupPtr; + int optLength, result; + const char *optStr; + + for (iLocal = 0, iArg = 0, localPtr = procPtr->firstLocalPtr; + iLocal < numArgs; + iLocal++, localPtr = localPtr->nextPtr) { + if (localPtr->flags & VAR_IS_ARGS) { + + /* + * 'args' last argument, copy remaining arguments (can be empty) + */ + + objPtr = Tcl_NewListObj(argCt-iArg, argObjs+iArg); + varPtr[iLocal].value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + iArg = argCt; /* all arguments have been handled */ + + } else if (localPtr->flags & VAR_NAMED_GROUP) { + + /* + * Start of a named argument group. Handle all of them together. + */ + + for (; iArg < argCt; iArg++) { + + if ((localPtr->argSpecPtr != NULL) + && (localPtr->argSpecPtr->remainAfterNamedGroup > 0) + && ((argCt - iArg) <= + localPtr->argSpecPtr->remainAfterNamedGroup)) { + /* Remaining arguments must be assigned to remaining + * positional locals after named group, end handling + */ + break; + } + + optStr = TclGetString(argObjs[iArg]); + + if (*optStr != '-') { + /* argument without leading dash, end named group */ + break; + } + + optStr++; + optLength = strlen(optStr); + + if ((optLength == 1) && (optStr[0] == '-')) { + /* end-of-option marker (--) */ + iArg++; + break; + } + + /* + * Find the referenced argument using the hash table + * created with the first name of the named group. + */ + + namedGroupPtr = NULL; + if (localPtr->argSpecPtr->namedHashTable != NULL) { + Tcl_HashEntry *hPtr; + hPtr = Tcl_FindHashEntry( + localPtr->argSpecPtr->namedHashTable, optStr); + if (hPtr != NULL) { + namedGroupPtr = Tcl_GetHashValue(hPtr); + } + } + + if (namedGroupPtr == NULL) { + return TCL_ERROR; /* not found */ + } else if (namedGroupPtr->valuePtr) { + objPtr = namedGroupPtr->valuePtr; + } else if (iArg+1 < argCt) { + objPtr = argObjs[++iArg]; + } else { + return TCL_ERROR; /* not enough input args */ + } + + if (namedGroupPtr->localPtr->flags & VAR_ARG_UPVAR) { + result = TclUpvarForExtArg(interp, + namedGroupPtr->localPtr->argSpecPtr->upvarLevelPtr, + objPtr, namedGroupPtr->localPtr->name); + if (result != TCL_OK) { + return result; + } + } else { + localVarPtr = &(varPtr[namedGroupPtr->localIndex]); + if (localVarPtr->value.objPtr != NULL) { + Tcl_DecrRefCount(localVarPtr->value.objPtr); + } + + localVarPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + } + + } + + /* + * Ensure that all variables in the named group have been + * set, have a default value or are optionals. localPtr is set + * to the last argument of the named group so that the loop + * will continue with the next argument. iLocal is updated in + * the same way. + */ + + for (; ; localPtr=localPtr->nextPtr, iLocal++) { + if (!varPtr[iLocal].value.objPtr) { + if (localPtr->defValuePtr) { + objPtr = localPtr->defValuePtr; + varPtr[iLocal].value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + } else if (!(localPtr->flags & VAR_ARG_OPTIONAL)) { + return TCL_ERROR; + } + } + + /* stop on the last argument of the named group */ + if ((localPtr->nextPtr == NULL) + || !(localPtr->nextPtr->flags & (VAR_NAMED_GROUP))) { + break; + } + } + } else if (iArg < argCt) { + + /* + * Set normal or 'upvar' variable using next input argument. + */ + + objPtr = argObjs[iArg++]; + if (localPtr->flags & VAR_ARG_UPVAR) { + result = TclUpvarForExtArg(interp, + localPtr->argSpecPtr->upvarLevelPtr, objPtr, + localPtr->name); + if (result != TCL_OK) { + return result; + } + } else { + varPtr[iLocal].value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + } + + } else if (localPtr->defValuePtr) { + + /* + * No more input arguments, set default value + */ + + objPtr = localPtr->defValuePtr; + varPtr[iLocal].value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + + } else if (!(localPtr->flags & VAR_ARG_OPTIONAL)) { + + /* + * No more input arguments, no default value, not optional. + */ + + return TCL_ERROR; + } + } + + if (iArg < argCt) { + + /* + * Remaining input arguments which have not been handled. + */ + + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcGetArgSpec -- + * + * This routine is invoked in order to build an argument specification + * for an existing argument. The TCL_GETARGSPEC_WITH_NAME or + * TCL_GETARGSPEC_TRY_OLDSTYLE flags can be used to change how the + * returned list is built. + * + * Results: + * Returns a pointer to a newly allocated Tcl_Obj list. + * + * Side effects: + * The returned list is allocated. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclProcGetArgSpec( + Tcl_Interp *interp, + CompiledLocal *localPtr, + int flags) +{ + Tcl_Obj *listObjPtr, *nameListPtr = NULL, *switchListPtr = NULL; + NamedGroupEntry *ngPtr; + + listObjPtr = Tcl_NewListObj(0, NULL); + + if (flags & TCL_GETARGSPEC_WITH_NAME) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj(localPtr->name, localPtr->nameLength)); + + } + + if ((flags & TCL_GETARGSPEC_TRY_OLDSTYLE) + && (!TclIsVarWithExtArgs(localPtr))) { + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(interp, listObjPtr, + localPtr->defValuePtr); + } + return listObjPtr; + } + + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj("-default", -1)); + Tcl_ListObjAppendElement(interp, listObjPtr, + localPtr->defValuePtr); + } + + if ((localPtr->flags & VAR_NAMED_GROUP) + && !(localPtr->flags & VAR_ARG_OPTIONAL)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj("-required", -1)); + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewBooleanObj(1)); + } else if (!(localPtr->flags & VAR_NAMED_GROUP) + && (localPtr->flags & VAR_ARG_OPTIONAL)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj("-required", -1)); + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewBooleanObj(0)); + } + + if ((localPtr->argSpecPtr != NULL) && (localPtr->flags & VAR_ARG_UPVAR)) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj("-upvar", -1)); + Tcl_ListObjAppendElement(interp, listObjPtr, + localPtr->argSpecPtr->upvarLevelPtr); + } + + if ((localPtr->argSpecPtr != NULL) + && (localPtr->argSpecPtr->firstNamedEntryPtr != NULL)) { + for (ngPtr = localPtr->argSpecPtr->firstNamedEntryPtr; + ngPtr != NULL; + ngPtr = ngPtr->nextPtr) { + Tcl_Obj *objArray[2] = { + Tcl_NewStringObj(ngPtr->name, ngPtr->nameLength), + ngPtr->valuePtr + }; + if (objArray[1] == NULL) { + if (nameListPtr == NULL) { + nameListPtr = Tcl_NewListObj(0, NULL); + } + Tcl_ListObjAppendElement(interp, nameListPtr, objArray[0]); + } else if ((objArray[0]->length == objArray[1]->length) + && (strcmp(Tcl_GetString(objArray[0]), Tcl_GetString(objArray[1])) == 0)) { + if (switchListPtr == NULL) { + switchListPtr = Tcl_NewListObj(0, NULL); + } + Tcl_ListObjAppendElement(interp, switchListPtr, objArray[0]); + } else { + if (switchListPtr == NULL) { + switchListPtr = Tcl_NewListObj(0, NULL); + } + Tcl_ListObjAppendElement(interp, switchListPtr, + Tcl_NewListObj(2, objArray)); + } + } + } + + if (nameListPtr != NULL) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj("-name", -1)); + Tcl_ListObjAppendElement(interp, listObjPtr, nameListPtr); + } + + if (switchListPtr != NULL) { + Tcl_ListObjAppendElement(interp, listObjPtr, + Tcl_NewStringObj("-switch", -1)); + Tcl_ListObjAppendElement(interp, listObjPtr, switchListPtr); + } + + return listObjPtr; +} /* *---------------------------------------------------------------------- * * TclPushProcCallFrame -- @@ -2008,24 +2849,12 @@ lastPtr->nextPtr = NULL; } else { procPtr->firstLocalPtr = NULL; } procPtr->lastLocalPtr = lastPtr; - while (clPtr) { - CompiledLocal *toFree = clPtr; - - clPtr = clPtr->nextPtr; - if (toFree->resolveInfo) { - if (toFree->resolveInfo->deleteProc) { - toFree->resolveInfo->deleteProc(toFree->resolveInfo); - } else { - ckfree(toFree->resolveInfo); - } - } - ckfree(toFree); - } procPtr->numCompiledLocals = procPtr->numArgs; + ProcCompiledLocalsFree(clPtr); } (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); @@ -2142,40 +2971,19 @@ void TclProcCleanupProc( register Proc *procPtr) /* Procedure to be deleted. */ { - register CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; - Tcl_Obj *defPtr; - Tcl_ResolvedVarInfo *resVarInfo; Tcl_HashEntry *hePtr = NULL; CmdFrame *cfPtr = NULL; Interp *iPtr = procPtr->iPtr; if (bodyPtr != NULL) { Tcl_DecrRefCount(bodyPtr); } - for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) { - CompiledLocal *nextPtr = localPtr->nextPtr; - - resVarInfo = localPtr->resolveInfo; - if (resVarInfo) { - if (resVarInfo->deleteProc) { - resVarInfo->deleteProc(resVarInfo); - } else { - ckfree(resVarInfo); - } - } - - if (localPtr->defValuePtr != NULL) { - defPtr = localPtr->defValuePtr; - Tcl_DecrRefCount(defPtr); - } - ckfree(localPtr); - localPtr = nextPtr; - } + ProcCompiledLocalsFree(procPtr->firstLocalPtr); ckfree(procPtr); /* * TIP #280: Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for @@ -2202,10 +3010,85 @@ cfPtr->line = NULL; ckfree(cfPtr); } Tcl_DeleteHashEntry(hePtr); } + + +/* + *---------------------------------------------------------------------- + * + * ProcCompiledLocalsFree -- + * + * This function does all the real work of freeing up a CompiledLocal + * linked list. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed. + * + *---------------------------------------------------------------------- + */ + +static void +ProcCompiledLocalsFree( + CompiledLocal *localPtr) +{ + CompiledLocal *nextLocalPtr = localPtr; + Tcl_ResolvedVarInfo *resVarInfo; + NamedGroupEntry *entryPtr, *nextEntryPtr; + + while (nextLocalPtr != NULL) { + localPtr = nextLocalPtr; + nextLocalPtr = nextLocalPtr->nextPtr; + + resVarInfo = localPtr->resolveInfo; + if (resVarInfo) { + if (resVarInfo->deleteProc) { + resVarInfo->deleteProc(resVarInfo); + } else { + ckfree(resVarInfo); + } + } + + if (localPtr->defValuePtr != NULL) { + Tcl_DecrRefCount(localPtr->defValuePtr); + } + + if (localPtr->argSpecPtr != NULL) { + entryPtr = localPtr->argSpecPtr->firstNamedEntryPtr; + + while (entryPtr != NULL) { + nextEntryPtr = entryPtr->nextPtr; + + if (entryPtr->valuePtr) { + Tcl_DecrRefCount(entryPtr->valuePtr); + } + + ckfree(entryPtr); + 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); + } + + ckfree(localPtr); + } +} /* *---------------------------------------------------------------------- * * TclUpdateReturnInfo -- Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -4409,10 +4409,57 @@ localNamePtr, flags, -1); Tcl_DecrRefCount(part1Ptr); Tcl_DecrRefCount(localNamePtr); return result; } + +/* + *---------------------------------------------------------------------- + * + * TclUpvarForExtArg -- + * + * This function links one variable to another. It is used during + * initialization of proc variables which use the upvar extended + * argument specification. + * + * Results: + * A standard Tcl completion code. If an error occurs then an error + * message is left in the interp's result. + * + * Side effects: + * The variable in upper frame whose name is given by varName becomes + * accessible under the name localNameStr, so that references to + * localNameStr are redirected to the other variable like a symbolic + * link. + * + *---------------------------------------------------------------------- + */ +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. */ +{ + int result; + CallFrame *framePtr; + Tcl_Obj *localNamePtr; + + if (TclObjGetFrame(interp, frameNamePtr, &framePtr) == -1) { + return TCL_ERROR; + } + + localNamePtr = Tcl_NewStringObj(localNameStr, -1); + Tcl_IncrRefCount(localNamePtr); + + result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0, + localNamePtr, 0, -1); + Tcl_DecrRefCount(localNamePtr); + return result; +} /* *---------------------------------------------------------------------- * * Tcl_GetVariableFullName -- Index: tests/apply.test ================================================================== --- tests/apply.test +++ tests/apply.test @@ -47,11 +47,11 @@ invoked from within "apply $lambda"}} test apply-2.3 {malformed lambda} { set lambda [list {{a b c}} boo] list [catch {apply $lambda} msg] $msg $::errorInfo -} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c" +} {1 {unknown argument option "b" or too many fields in argument specifier "a b c"} {unknown argument option "b" or too many fields in argument specifier "a b c" (parsing lambda expression "{{a b c}} boo") invoked from within "apply $lambda"}} test apply-2.4 {malformed lambda} { set lambda [list a(1) boo] Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -38,11 +38,11 @@ proc t1 {a bbb c} {return foo} info args t1 } {a bbb c} test info-1.2 {info args option} { proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} - info a t1 + info args t1 } {a bbb c args} test info-1.3 {info args option} { proc t1 "" {return foo} info args t1 } {} @@ -676,20 +676,20 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { info } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, argspec, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, argspec, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, argspec, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, argspec, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### ## info frame @@ -2412,10 +2412,99 @@ } -cleanup { unset -nocomplain body rename demo {} rename probe {} } -result 3 + +# ------------------------------------------------------------------------- +# info argspec +test info-40-0 {info argspec missing type} -body { + info argspec +} -returnCodes error -result {wrong # args: should be "info argspec type ..."} +test info-40-1 {info argspec proc with old-style proc} { + proc p { a { b 1 } { c {} } } {} + list [info argspec proc p a] [info argspec proc p b] [info argspec proc p c] +} {{} {-default 1} {-default {}}} +test info-40-2 {info argspec proc missing procname} -body { + info argspec proc +} -returnCodes error -result {wrong # args: should be "info argspec proc procname ?arg?"} +test info-40-3 {info argspec proc too many args} -body { + info argspec proc proc arg foo +} -returnCodes error -result {wrong # args: should be "info argspec proc procname ?arg?"} +test info-40-4 {info argspec proc unknown proc} -body { + info argspec proc fooproc x +} -returnCodes error -result {"fooproc" isn't a procedure} +test info-40-5 {info argspec proc unknown arg} -body { + proc p {a} {} + info argspec proc p x +} -returnCodes error -result {proc "p" doesn't have an argument "x"} +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 with new-style proc} { + proc p { + { a -default 2 } + { b -upvar #1 } + { c -required 0 } + } {} + 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-9 {info argspec proc without arg} { + proc p { + { a -default 2 } + { b -name {B B1} -required 1 } + args + } {} + info argspec proc p +} {{a -default 2} {b -required 1 -name {B B1}} args} +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-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-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-13 {info argspec specifiers} { + info argspec specifiers +} {-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}} {} + list [info argspec objmethod foo bar] [info argspec objmethod foo bar c] +} -cleanup { + foo destroy +} -result {{a {b -default B} {c -default 0 -switch {{C 1}}}} {-default 0 -switch {{C 1}}}} +test info-40-15 {info argspec constructor} -setup { + oo::class create testClass { + constructor {{a -default 0 -name A}} { } + } +} -body { + list [info argspec constructor testClass] [info argspec constructor testClass a] +} -cleanup { + testClass destroy +} -result {{{a -default 0 -name A}} {-default 0 -name A}} +test info-40-16 {info argspec method} -setup { + oo::class create testClass { + method m {a {b -required 0}} { } + } +} -body { + list [info argspec method testClass m] [info argspec method testClass m b] +} -cleanup { + testClass destroy +} -result {{a {b -required 0}} {-required 0}} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return Index: tests/oo.test ================================================================== --- tests/oo.test +++ tests/oo.test @@ -3763,10 +3763,76 @@ # Bug makes this crash, especially with mem-debugging on oo::class create B {} oo::class create D {mixin B} namespace eval [info object namespace D] [list [namespace which B] destroy] } {} + +# TIP457-related tests +test oo-36.1 {OO/CloneProcedureMethod with extended argspec} { + oo::object create foo + oo::objdefine foo { + method p { {x -default off -switch {{ON on}}} } { + lappend ::result [self object] >$x< + } + } + set result {} + foo p; foo p -ON + oo::copy foo bar + bar p; bar p -ON + foo destroy; bar destroy + set result +} {::foo >off< ::foo >on< ::bar >off< ::bar >on<} +catch {foo destroy} +catch {bar destroy} + +test oo-36.2 {OO/clonedBody with extended argspec} -setup { + oo::class create ArbitraryClass {export eval} +} -body { + ArbitraryClass create a + a eval {proc foo {a {n -name num -default 3}} { + return [string repeat $a $n] + }} + set result [a eval {foo A -num 2}] + oo::copy a b + lappend result [b eval {foo B -num 4}] [b eval {foo C}] +} -cleanup { + ArbitraryClass destroy +} -result {AA BBBB CCC} + +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 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} 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 1} + args} {body} + set result [info class definition foo bar] +} -cleanup { + foo destroy +} -result {{a {b 8} {c -name C} {d -upvar 1 -name D} args} body} + +test oo-36.5 {OO constructor with extended argspec} { + oo::class create testClass { + constructor {{a -default 0 -name A}} { + global result + lappend result [self object] $a + } + } + set result {} + testClass create foo1 + testClass create foo2 -A 5 + testClass destroy + return $result +} {::foo1 0 ::foo2 5} cleanupTests return ADDED tests/proc-enh.test Index: tests/proc-enh.test ================================================================== --- /dev/null +++ tests/proc-enh.test @@ -0,0 +1,268 @@ +# Commands covered: proc +# +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +testConstraint procbodytest [expr {![catch {package require procbodytest}]}] + +# proc-enh-1.x: error while parsing argspec +test proc-enh-1.1 {argspec parsing error: unexpected fields number} { + list [catch { + proc p {{a -default 1 -name}} {} + } msg] $msg $errorCode +} {1 {unexpected fields number in argument specifier "a -default 1 -name"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.2 {argspec parsing error: argument with no name} { + list [catch { + proc p {{}} {} + } msg] $msg $errorCode +} {1 {argument with no name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.3 {argspec parsing error: formal parameter is an array elt} { + list [catch { + proc p {a(1)} {} + } msg] $msg $errorCode +} {1 {formal parameter "a(1)" is an array element} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.4 {argspec parsing error: formal parameter is not a simple name} { + list [catch { + proc p {a::b} {} + } msg] $msg $errorCode +} {1 {formal parameter "a::b" is not a simple name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.5 {argspec parsing error: unknown option} { + list [catch { + proc p {{a -foo 1}} {} + } msg] $msg $errorCode +} {1 {unknown argument option "-foo" or too many fields in argument specifier "a -foo 1"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.5b {argspec parsing error: unknown option} { + list [catch { + proc p {{a foo 1}} {} + } msg] $msg $errorCode +} {1 {unknown argument option "foo" or too many fields in argument specifier "a foo 1"} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.6 {argspec parsing error: empty named argument} { + list [catch { + proc p {{a -name {""}}} {} + } msg] $msg $errorCode +} {1 {named argument with no name} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.7 {argspec parsing error: named argument with space} { + list [catch { + proc p {{a -name {"a b"}}} {} + } msg] $msg $errorCode +} {1 {named argument "a b" with unexpected space character} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.8 {argspec parsing error: empty named argument (switch)} { + list [catch { + proc p {{a -switch {a {}}}} {} + } msg] $msg $errorCode +} {1 {incorrect switch value ""} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.9 {argspec parsing error: named argument with space (switch)} { + list [catch { + proc p {{a -switch {a {"a b" 3}}}} {} + } msg] $msg $errorCode +} {1 {named argument "a b" with unexpected space character} {TCL OPERATION PROC FORMALARGUMENTFORMAT}} +test proc-enh-1.10 {argspec parsing error: two many fields in switch} { + list [catch { + 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 bad level} { + list [catch { + proc p {{a -upvar foo}} {} + } msg] $msg $errorCode +} {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 -upvar -1}} {} + } msg] $msg $errorCode +} {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.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.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}} + +# proc-enh-2.x: correct usage +test proc-enh-2.1 {correct usage: -default} { + proc p { { a -default 1 } } { list $a } + list [p] [p 2] +} {1 2} +test proc-enh-2.2 {correct usage: -default set twice} { + proc p { { a -default 1 -default 2 } } { return $a }; p +} {2} +test proc-enh-2.3 {correct usage: -name} { + proc p {{a -name A} {b -name {B0 B1}} {c -name C0 -name C1}} { + list $a $b $c + }; + list [p -B0 5 -A 1 -C1 6] [p -C0 0 -B1 8 -A 2 -C0 3] +} {{1 5 6} {2 8 3}} +test proc-enh-2.4 {correct usage: -switch} { + proc p {{a -switch {A}} {b -switch {B0 {B1 b1}}} {c -switch {{C0 c0}} -switch C1}} { + list $a $b $c + }; + list [p -B1 -C1 -A] [p -A -C0 -B0] +} {{A b1 C1} {A B0 c0}} +test proc-enh-2.5 {correct usage: -switch + -name} { + proc p {{v -name val -switch {{low 0} {high 9}}}} { return $v } + list [p -low] [p -val 5] [p -high] +} {0 5 9} +test proc-enh-2.6 {correct usage: -required} { + proc p {{a -required 0}} { + if {[info exists a]} { return $a } else { return unset } + }; + list [p] [p 2] +} {unset 2} +test proc-enh-2.7 {correct usage: -required + -switch} { + proc p {{a -required 0 -switch dbg}} { + if {[info exists a]} { return $a } else { return unset } + }; + list [p] [p -dbg] +} {unset dbg} +test proc-enh-2.8 {correct usage: -upvar} { + 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] [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] +} {{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 + } + list [p foo] [p -B 3 -- -A 5] +} {{0 1 foo} {0 3 {-A 5}}} +test proc-enh-2.11 {correct usage: -upvar inside a named group (not last one)} { + proc p {{v -name var -upvar 1} {i -default 1 -name incr}} { + incr v $i + } + if [info exists i] {unset i} + 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} {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] +} {{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 + } + list [p -B 5 -E -D] [p -- foo -E] +} {{0 B 5 D E} {0 0 foo 0 E}} +test proc-enh-2.14 {correct usage: named arg without required is optionnal} { + proc p {{a -name A}} { + if {[info exists a]} { return $a } else { return unset } + }; + list [p] [p -A 2] +} {unset 2} +test proc-enh-2.15 {correct usage: fixed number of arguments after named group, automatically ended} { + proc p {{a -name A -default 0} {b -name B -default 0} c} { + list $a $b $c + }; + set l [list -Z 1] + list [p -2] [p -A 1 -5] [p -- -3] [p --] +} {{0 0 -2} {1 0 -5} {0 0 -3} {0 0 --}} + +# proc-enh-3.x: wrong # args +test proc-enh-3.1 {wrong # args: -name arg without value} { + proc p {{a -name A} {b -name B -default 1}} { } + list [catch { p -A } msg] $msg $errorCode +} {1 {wrong # args: should be "p ?|-A a|? ?|-B b|?"} {TCL WRONGARGS}} +test proc-enh-3.2 {wrong # args: named group ended by an arg with leading dash} { + proc p {{a -name A} {b -name B} args} { } + list [catch { p -b Z -5 } msg] $msg $errorCode +} {1 {wrong # args: should be "p ?|-A a|? ?|-B b|? ?arg ...?"} {TCL WRONGARGS}} +test proc-enh-3.3 {wrong # args: named group followed by too many options} { + proc p {{a -name A -default 1} b} { } + list [catch { p -- 5 6 } msg] $msg $errorCode +} {1 {wrong # args: should be "p ?|-A a|? b"} {TCL WRONGARGS}} +test proc-enh-3.4 {wrong # args: required named group with name+switch} { + proc p {{a -name A -switch {A0 A1} -required 1}} { } + list [catch { p } msg] $msg $errorCode +} {1 {wrong # args: should be "p |-A a|-A0|-A1|"} {TCL WRONGARGS}} +test proc-enh-3.5 {wrong # args: required named group with upvar} { + proc p {{a -name A -upvar 1 -required 1} {b -upvar 1}} { } + list [catch { p } msg] $msg $errorCode +} {1 {wrong # args: should be "p |-A &a&| &b&"} {TCL WRONGARGS}} +test proc-enh-3.6 {wrong # args: two distinct named group, specified in wrong order} { + proc p {{a -switch A} {b -switch B} c {d -switch D} {e -switch E}} { } + list [catch { p -E 1 } msg] $msg $errorCode +} {1 {wrong # args: should be "p ?|-A|? ?|-B|? c ?|-D|? ?|-E|?"} {TCL WRONGARGS}} + +# proc-enh-4.x: errors during call +test proc-enh-4.1 {errors during call: -upvar read access with non-existing arg} { + proc p {{a -upvar 1}} { return $a } + if [info exists v] { unset v} + list [catch { p v } msg] $msg $errorCode +} {1 {can't read "a": no such variable} {TCL READ VARNAME}} +test proc-enh-4.2 {errors during call: -upvar read access with non-existing arg + -name} { + proc p {{a -upvar 1 -name A}} { return $a } + if [info exists v] { unset v} + list [catch { p -A v } msg] $msg $errorCode +} {1 {can't read "a": no such variable} {TCL READ VARNAME}} + +# proc-enh-5.x: precompiled +test proc-enh-5.1 {precompiled: inconsistent arg default value} -body { + proc p {x y {z -default 2}} { } + procbodytest::proc t {x y {z ZZ}} p +} -constraints procbodytest -returnCodes error -cleanup { + catch {rename p ""} + catch {rename t ""} +} -result {procedure "t": formal parameter "z" has argument spec inconsistent with precompiled body} +test proc-enh-5.2 {precompiled: inconsistent arg spec} -body { + proc p {x y {z -name z}} { } + procbodytest::proc t {x y {z -name ZZ}} p +} -constraints procbodytest -returnCodes error -cleanup { + catch {rename p ""} + 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} z} { } + procbodytest::proc t {x {y -upvar 1} z} p +} -constraints procbodytest -result {} + +# proc-enh-6.x: apply/lambda +test proc-enh-6.1 {apply/lambda: wrong args} { + set lambda [list {{a -name A -switch A1 -required 1} {b -default B0 -name B}} {list $a $b}] + list [catch { + apply $lambda + } msg] $msg $errorCode +} {1 {wrong # args: should be "apply lambdaExpr |-A a|-A1| ?|-B b|?"} {TCL WRONGARGS}} +test proc-enh-6.2 {apply/lambda: correct usage} { + set lambda [list {{a -name A -switch A1} {b -default B0 -name B}} {list $a $b}] + list [apply $lambda -A1] [apply $lambda -B 4 -A 8] +} {{A1 B0} {8 4}} + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: Index: tests/proc-old.test ================================================================== --- tests/proc-old.test +++ tests/proc-old.test @@ -276,11 +276,11 @@ test proc-old-5.6 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg } {1 {argument with no name}} test proc-old-5.7 {error conditions} { list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg -} {1 {too many fields in argument specifier "x 1 2"}} +} {1 {unknown argument option "1" or too many fields in argument specifier "x 1 2"}} test proc-old-5.8 {error conditions} { catch {return} } 2 proc tproc {} { set a 22 Index: tests/proc.test ================================================================== --- tests/proc.test +++ tests/proc.test @@ -262,11 +262,11 @@ procbodytest::proc t {x y z} p lappend rv [t S T U] } -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} -} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +} -result {procedure "t": formal parameter "z" has argument spec inconsistent with precompiled body} test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body { proc p {x y z} { set v [join [list $x $y $z]] set w [string tolower $v] return "$v:$w" @@ -275,11 +275,11 @@ procbodytest::proc t {x y {z Z}} p lappend rv [t S T U] } -returnCodes error -constraints procbodytest -cleanup { catch {rename p ""} catch {rename t ""} -} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +} -result {procedure "t": formal parameter "z" has argument spec inconsistent with precompiled body} test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -body { proc p {x y {z Z}} { set v [join [list $x $y $z]] set w [string tolower $v] return "$v:$w" @@ -288,11 +288,11 @@ procbodytest::proc t {x y {z ZZ}} p lappend rv [t S T U] } -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} -} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} +} -result {procedure "t": formal parameter "z" has argument spec inconsistent with precompiled body} test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup { proc getbytes {} { set lines [split [memory info] "\n"] lindex $lines 3 3 }