TIP#457: Update named group ending

* Detect simultaneous usage of both -upvar and -value.
* Fix -upvar usage with several -name options.
* Return a more appropriate error message when a pass-by-name
  argument is used with a non-existing variable.

doc/info.n

@@ -29,6 +29,12 @@ 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
@@ -398,6 +404,81 @@ 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

doc/proc.n

@@ -30,9 +30,14 @@ the procedure is created in the specified namespace.
 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
@@ -42,7 +47,7 @@ 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
@@ -53,7 +58,11 @@ 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
@@ -67,7 +76,8 @@ 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
@@ -82,6 +92,87 @@ invoked, the procedure's return value is the value specified in a
 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
@@ -109,15 +200,39 @@ them out, one by one.
 }
 .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)

generic/tclCmdIL.c

@@ -19,6 +19,8 @@
 
 #include "tclInt.h"
 #include "tclRegexp.h"
+#include "tclCompile.h"
+#include "tclOOInt.h"
 
 /*
  * During execution of the "lsort" command, structures of the following type
@@ -108,6 +110,8 @@ 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,
@@ -161,6 +165,7 @@ static Tcl_Obj *	SelectObjFromSublist(Tcl_Obj *firstPtr,
 
 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},
@@ -515,6 +520,275 @@ InfoArgsCmd(
     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;
+}
+
 /*
  *----------------------------------------------------------------------
  *

generic/tclCompile.c

@@ -3032,6 +3032,7 @@ TclFindCompiledLocal(
 	}
 	localPtr->defValuePtr = NULL;
 	localPtr->resolveInfo = NULL;
+	localPtr->argSpecPtr = NULL;
 
 	if (name != NULL) {
 	    memcpy(localPtr->name, name, (size_t) nameBytes);

generic/tclInt.h

@@ -698,6 +698,13 @@ typedef struct VarInHash {
  *				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.
  */
 
 /*
@@ -739,6 +746,9 @@ typedef struct VarInHash {
 #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.
@@ -845,6 +855,9 @@ typedef struct VarInHash {
 #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 \
@@ -893,9 +906,61 @@ typedef struct VarInHash {
 /*
  * 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
@@ -923,7 +988,8 @@ typedef struct CompiledLocal {
     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. */
@@ -934,6 +1000,9 @@ typedef struct CompiledLocal {
 				 * 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
@@ -965,6 +1034,7 @@ typedef struct Proc {
     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
@@ -976,6 +1046,19 @@ typedef struct Proc {
 				 * 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 ...).
@@ -2860,6 +2943,15 @@ struct Tcl_LoadHandle_ {
 #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:
@@ -3067,6 +3159,8 @@ MODULE_SCOPE void	TclParseInit(Tcl_Interp *interp, const char *string,
 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);
@@ -3180,6 +3274,9 @@ 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);

generic/tclOO.c

@@ -186,8 +186,7 @@ static const char *clonedBody =
 "    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];"

generic/tclOOInfo.c

@@ -268,14 +268,9 @@ InfoObjectDefnCmd(
     for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
 	    localPtr=localPtr->nextPtr) {
 	if (TclIsVarArgument(localPtr)) {
-	    Tcl_Obj *argObj;
+	    Tcl_Obj *argObj = TclProcGetArgSpec(interp, localPtr,
+		    TCL_GETARGSPEC_WITH_NAME|TCL_GETARGSPEC_TRY_OLDSTYLE);
 
-	    argObj = Tcl_NewObj();
-	    Tcl_ListObjAppendElement(NULL, argObj,
-		    Tcl_NewStringObj(localPtr->name, -1));
-	    if (localPtr->defValuePtr != NULL) {
-		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
-	    }
 	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
 	}
     }
@@ -858,14 +853,9 @@ InfoClassConstrCmd(
     for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
 	    localPtr=localPtr->nextPtr) {
 	if (TclIsVarArgument(localPtr)) {
-	    Tcl_Obj *argObj;
+	    Tcl_Obj *argObj = TclProcGetArgSpec(interp, localPtr,
+		    TCL_GETARGSPEC_WITH_NAME|TCL_GETARGSPEC_TRY_OLDSTYLE);
 
-	    argObj = Tcl_NewObj();
-	    Tcl_ListObjAppendElement(NULL, argObj,
-		    Tcl_NewStringObj(localPtr->name, -1));
-	    if (localPtr->defValuePtr != NULL) {
-		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
-	    }
 	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
 	}
     }
@@ -926,14 +916,9 @@ InfoClassDefnCmd(
     for (localPtr=procPtr->firstLocalPtr; localPtr!=NULL;
 	    localPtr=localPtr->nextPtr) {
 	if (TclIsVarArgument(localPtr)) {
-	    Tcl_Obj *argObj;
+	    Tcl_Obj *argObj = TclProcGetArgSpec(interp, localPtr,
+		    TCL_GETARGSPEC_WITH_NAME|TCL_GETARGSPEC_TRY_OLDSTYLE);
 
-	    argObj = Tcl_NewObj();
-	    Tcl_ListObjAppendElement(NULL, argObj,
-		    Tcl_NewStringObj(localPtr->name, -1));
-	    if (localPtr->defValuePtr != NULL) {
-		Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
-	    }
 	    Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
 	}
     }

generic/tclOOMethod.c

@@ -1297,13 +1297,9 @@ CloneProcedureMethod(
     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);
 	}
     }

generic/tclVar.c

@@ -4412,6 +4412,53 @@ Tcl_UpVar2(
     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;
+}
+
 /*
  *----------------------------------------------------------------------
  *

tests/apply.test

@@ -49,7 +49,7 @@ test apply-2.2 {malformed 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"}}

tests/info.test

@@ -40,7 +40,7 @@ test info-1.1 {info args option} {
 } {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}
@@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
 } -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}
 
 ##
 # ### ### ### ######### ######### #########
@@ -2415,6 +2415,95 @@ test info-39.0 {Bug 4b61afd660} -setup {
     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

tests/oo.test

@@ -3766,6 +3766,72 @@ test oo-35.4 {Bug 593baa032c: mixins list teardown} {
     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

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:

tests/proc-old.test

@@ -278,7 +278,7 @@ test proc-old-5.6 {error conditions} {
 } {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

tests/proc.test

@@ -264,7 +264,7 @@ test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body
 } -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]]
@@ -277,7 +277,7 @@ test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body
 } -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]]
@@ -290,7 +290,7 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -bod
 } -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"]