Index: doc/proc.n ================================================================== --- doc/proc.n +++ doc/proc.n @@ -29,41 +29,47 @@ \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 -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. -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. -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. -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. +then it is the name of a required argument; if there are two fields, then +the first is the name of an optional argument and the second is its default value. +Required arguments may only be in the beginning and in the end of the argument list, +surrounding any optional arguments. .PP There is one special case to permit procedures with -variable numbers of arguments. If the last formal argument has the name +variable numbers of arguments. If one 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 a list (as if the \fBlist\fR command had been used); this combined value is assigned to the local variable \fBargs\fR. .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. +.PP +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 unless \fBargs\fR is present. +.PP +Actual arguments are assigned to formal arguments in the following order. +.IP +Required arguments to the left are assigned from left-to-right. +.IP +Required arguments to the right are assigned from right-to-left. +.IP +Optional arguments to the left of any "\fBargs\fR" are assigned from left-to-right. +.IP +Optional arguments to the right of any "\fBargs\fR" are assigned from right-to-left. +.IP +Any remaining arguments are assigned to "\fBargs\fR" if it exists, or it is an error to have remaining arguments. +.PP 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, Index: generic/tclProc.c ================================================================== --- generic/tclProc.c +++ generic/tclProc.c @@ -409,10 +409,17 @@ Proc *procPtr = NULL; Tcl_Size i, numArgs; CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; int precompiled = 0, result; + /* + * To report on bad arglists: + * - set to 1 when 0 and optional/args is found + * - set to 2 when 1 and required is found + * - error when 2 and optional/args is found + */ + int arglistShape = 0, isArgs, seenArgs = 0; ProcGetInternalRep(bodyPtr, procPtr); if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already @@ -539,10 +546,38 @@ "FORMALARGUMENTFORMAT", NULL); goto procError; } argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength); + isArgs = (nameLength == 4) && !strcmp(argname, "args"); + + /* + * Reject invalid argspecs early + */ + if (fieldCount == 2 || isArgs) { + if (isArgs && seenArgs) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "repeated \"args\" in argument list", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); + goto procError; + } + seenArgs = seenArgs || isArgs; + if (arglistShape == 0) { + arglistShape = 1; + } else if (arglistShape == 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "required arg may not be in the middle", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); + goto procError; + } + } else { + if (arglistShape == 1) { + arglistShape = 2; + } + } /* * Check that the formal parameter name is a scalar. */ @@ -618,14 +653,11 @@ 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)) { + if (isArgs) { localPtr->flags |= VAR_IS_ARGS; } localPtr = localPtr->nextPtr; } else { @@ -653,14 +685,11 @@ Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } memcpy(localPtr->name, argname, fieldValues[0]->length + 1); - if ((i == numArgs - 1) - && (localPtr->nameLength == 4) - && (localPtr->name[0] == 'a') - && (memcmp(localPtr->name, "args", 4) == 0)) { + if (isArgs) { localPtr->flags |= VAR_IS_ARGS; } } } @@ -1065,21 +1094,21 @@ Tcl_Interp *interp, int skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; Proc *procPtr = framePtr->procPtr; - int localCt = procPtr->numCompiledLocals, numArgs, i; + int localCt = procPtr->numCompiledLocals, numArgs, i, i2 = 1; Tcl_Obj **desiredObjs; const char *final = NULL; /* * Build up desired argument list for Tcl_WrongNumArgs */ numArgs = framePtr->procPtr->numArgs; desiredObjs = (Tcl_Obj **)TclStackAlloc(interp, - sizeof(Tcl_Obj *) * (numArgs+1)); + sizeof(Tcl_Obj *) * (numArgs+2)); if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { desiredObjs[0] = framePtr->objv[skip-1]; @@ -1087,33 +1116,39 @@ Tcl_IncrRefCount(desiredObjs[0]); if (localCt > 0) { Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt); - for (i=1 ; i<=numArgs ; i++, defPtr++) { + for (i=i2=1 ; i<=numArgs ; i++, i2++, 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 { + /* + * Work around the list quoting in WrongNumArgs which we + * do not want for ?arg ...?. + */ + + TclNewLiteralStringObj(argObj, "?arg"); + desiredObjs[i2] = argObj; + i2++; + TclNewLiteralStringObj(argObj, "...?"); + } else { argObj = namePtr; Tcl_IncrRefCount(namePtr); } - desiredObjs[i] = argObj; + desiredObjs[i2] = argObj; } } Tcl_ResetResult(interp); - Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final); + Tcl_WrongNumArgs(interp, i2, desiredObjs, final); - for (i=0 ; i<=numArgs ; i++) { + for (i=0 ; ivarFramePtr; Proc *procPtr = framePtr->procPtr; ByteCode *codePtr; - Var *varPtr, *defPtr; - int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; - Tcl_Obj *const *argObjs; + Var *nextVarPtr, *lastVarPtr, *localVarPtr, *nextDefPtr, *lastDefPtr; + /* Total compiled locals, >= numArgs */ + int numLocals = procPtr->numCompiledLocals; + /* Number of arguments taken */ + int numArgs = procPtr->numArgs; + /* Number of arguments given */ + int argCt = framePtr->objc - skip; + Tcl_Obj *const *nextArgObj; + Tcl_Obj *const *lastArgObj; ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); /* * Make sure that the local cache of variable names and initial values has * been initialised properly . */ - if (localCt) { + if (numLocals) { if (!codePtr->localCachePtr) { InitLocalCache(procPtr) ; } framePtr->localCachePtr = codePtr->localCachePtr; framePtr->localCachePtr->refCount++; - defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + nextDefPtr = (Var *) (&framePtr->localCachePtr->varName0 + numLocals); + lastDefPtr = &nextDefPtr[numArgs-1]; } else { - defPtr = NULL; + nextDefPtr = NULL; + lastDefPtr = NULL; } /* * Create the "compiledLocals" array. Make sure it is large enough to hold * all the procedure's compiled local variables, including its formal * parameters. */ - varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var)); - framePtr->compiledLocals = varPtr; - framePtr->numCompiledLocals = localCt; + nextVarPtr = (Var *)TclStackAlloc(interp, numLocals * sizeof(Var)); + lastVarPtr = &nextVarPtr[numArgs-1]; + localVarPtr = &nextVarPtr[numArgs]; + framePtr->compiledLocals = nextVarPtr; + framePtr->numCompiledLocals = numLocals; /* * Match and assign the call's actual parameters to the procedure's formal * arguments. The formal arguments are described by the first numArgs * entries in both the Proc structure's local variable list and the call * frame's local variable array. */ - numArgs = procPtr->numArgs; - argCt = framePtr->objc - skip; /* Set it to the number of args to the - * procedure. */ + nextArgObj = framePtr->objv + skip; if (numArgs == 0) { if (argCt) { goto incorrectArgs; } else { goto correctArgs; } } - argObjs = framePtr->objv + skip; - 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'. - */ - - Tcl_Obj *objPtr = argObjs[i]; - - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } - for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) { - /* - * This loop is entered if argCt < (numArgs-1). Set default values; - * last formal is special. - */ - - Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL; - - if (!objPtr) { - goto incorrectArgs; - } - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var reference. */ - } - - /* - * When we get here, the last formal argument remains to be defined: - * defPtr and varPtr point to the last argument to be initialized. - */ - - varPtr->flags = 0; - if (defPtr && defPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i); - - varPtr->value.objPtr = listPtr; - Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ - } else if (argCt == numArgs) { - Tcl_Obj *objPtr = argObjs[i]; - - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) { - Tcl_Obj *objPtr = defPtr->value.objPtr; - - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ - } else { - goto incorrectArgs; - } - varPtr++; + lastArgObj = &nextArgObj[argCt-1]; + + /* + * Required args, LHS + */ + while ( (nextVarPtr <= lastVarPtr) + && !(nextDefPtr->flags & VAR_IS_ARGS) + && (nextDefPtr->value.objPtr == NULL) ) { + if (nextArgObj > lastArgObj) goto incorrectArgs; /* not enough args */ + nextVarPtr->flags = 0; + nextVarPtr->value.objPtr = *(nextArgObj++); + Tcl_IncrRefCount(nextVarPtr->value.objPtr); /* Local var is a reference. */ + + ++nextVarPtr; ++nextDefPtr; + } + /* + * Required args, RHS + */ + while ( (nextVarPtr <= lastVarPtr) + && !(lastDefPtr->flags & VAR_IS_ARGS) + && (lastDefPtr->value.objPtr == NULL) ) { + if (nextArgObj > lastArgObj) goto incorrectArgs; /* not enough args */ + lastVarPtr->flags = 0; + lastVarPtr->value.objPtr = *(lastArgObj--); + Tcl_IncrRefCount(lastVarPtr->value.objPtr); /* Local var is a reference. */ + + --lastVarPtr; --lastDefPtr; + } + /* + * Optional args, LHS + */ + while ( (nextVarPtr <= lastVarPtr) + && !(nextDefPtr->flags & VAR_IS_ARGS) ) { + Tcl_Obj * objPtr; + if (nextArgObj > lastArgObj) { + objPtr = nextDefPtr->value.objPtr; /* take default */ + } else { + objPtr = *(nextArgObj++); + } + if (objPtr == NULL) Tcl_Panic("oops LHS!"); + nextVarPtr->value.objPtr = objPtr; + nextVarPtr->flags = 0; + Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ + + ++nextVarPtr; ++nextDefPtr; + } + /* + * Optional args, RHS + */ + while ( (nextVarPtr <= lastVarPtr) + && !(lastDefPtr->flags & VAR_IS_ARGS) ) { + Tcl_Obj * objPtr; + if (nextArgObj > lastArgObj) { + objPtr = lastDefPtr->value.objPtr; /* take default */ + } else { + objPtr = *(lastArgObj--); + } + if (objPtr == NULL) Tcl_Panic("oops RHS!"); + lastVarPtr->value.objPtr = objPtr; + lastVarPtr->flags = 0; + Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ + + --lastVarPtr; --lastDefPtr; + } + /* + * Args? + */ + if (nextVarPtr < lastVarPtr) { + Tcl_Panic("nextVarPtr < lastVarPtr!\n"); + } + if (nextVarPtr == lastVarPtr) { + if (!(nextDefPtr->flags & VAR_IS_ARGS)) { + goto incorrectArgs; + } + Tcl_Obj *listPtr = Tcl_NewListObj(1+lastArgObj-nextArgObj, nextArgObj); + nextVarPtr->value.objPtr = listPtr; + nextVarPtr->flags = 0; + Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ + } else { + if (nextArgObj <= lastArgObj) { + goto incorrectArgs; + } + } /* * Initialise and resolve the remaining compiledLocals. In the absence of * resolvers, they are undefined local vars: (flags=0, value=NULL). */ correctArgs: - if (numArgs < localCt) { + if (numArgs < numLocals) { if (!framePtr->nsPtr->compiledVarResProc && !((Interp *)interp)->resolverPtr) { - memset(varPtr, 0, (localCt - numArgs)*sizeof(Var)); + memset(localVarPtr, 0, (numLocals - numArgs)*sizeof(Var)); } else { - InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr); + InitResolvedLocals(interp, codePtr, localVarPtr, framePtr->nsPtr); } } return TCL_OK; @@ -1476,12 +1547,15 @@ incorrectArgs: if ((skip != 1) && TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } - memset(varPtr, 0, - ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var)); + /* + * Ensure all un-assigned vars are zeroed + */ + memset(nextVarPtr, 0, + ((framePtr->compiledLocals + numLocals)-nextVarPtr) * sizeof(Var)); return ProcWrongNumArgs(interp, skip); } /* *---------------------------------------------------------------------- Index: tests/proc-old.test ================================================================== --- tests/proc-old.test +++ tests/proc-old.test @@ -198,18 +198,17 @@ proc tproc {x {y y-default} {z z-default}} { return [list $x $y $z] } list [catch {tproc} msg] $msg } {1 {wrong # args: should be "tproc x ?y? ?z?"}} +# Prior to TIP#288, this was an error test proc-old-30.8 {arguments and defaults} { - list [catch { - proc tproc {x {y y-default} z} { - return [list $x $y $z] - } - tproc 2 3 - } msg] $msg -} {1 {wrong # args: should be "tproc x ?y? z"}} + proc tproc {x {y y-default} z} { + return [list $x $y $z] + } + tproc 2 3 +} {2 y-default 3} test proc-old-30.9 {arguments and defaults} { proc tproc {x {y y-default} args} { return [list $x $y $args] } tproc 2 3 4 5 ADDED tests/tip288.test Index: tests/tip288.test ================================================================== --- /dev/null +++ tests/tip288.test @@ -0,0 +1,102 @@ +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +testConstraint procbodytest [expr {![catch {package require procbodytest}]}] +testConstraint memory [llength [info commands memory]] + +set setup { + proc x {a args b} { + return "a=$a, args=$args, b=$b" + } + proc y {a {b x} args c} { + return "a=$a, b=$b, args=$args, c=$c" + } +} +set cleanup {rename x {}; rename y {}} + +test tip288-1.1 {Error cases, repeated args} -body { + proc z {a args args} { + } +} -returnCodes error -result {repeated "args" in argument list} + +test tip288-1.2 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body { + x 1 2 +} -result {a=1, args=, b=2} + +test tip288-1.3 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body { + x 1 2 3 +} -result {a=1, args=2, b=3} + +test tip288-1.4 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body { + x 1 +} -returnCodes error -result {wrong # args: should be "x a ?arg ...? b"} + +test tip288-1.5 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body { + y 1 2 3 +} -result {a=1, b=2, args=, c=3} + +test tip288-1.6 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body { + y 1 2 +} -result {a=1, b=x, args=, c=2} + +# This is now an error +test tip288-1.7 {Examples for TIP#288} -body { + proc z {a {b x} c args} { + return "a=$a, b=$b, c=$c, args=$args" + } +} -returnCodes error -result {required arg may not be in the middle} + +# A default value for "args" is still allowed but pointless +test tip288-1.8 {Examples for TIP#288} -body { + proc z {a b {args {b}}} { + return "a=$a, b=$b, args=$args" + } + z 1 2 +} -result {a=1, b=2, args=} + + +set setup { + proc x {a b {c _c} {d _d} args {e _e} {f _f} g h} { + list a $a b $b c $c d $d e $e f $f g $g h $h args $args + } +} +set cleanup {rename x {}} + +test tip288-2.1 {Pathological arglist} -setup $setup -cleanup $cleanup -body { + x 1 2 3 +} -returnCodes error -result {wrong # args: should be "x a b ?c? ?d? ?arg ...? ?e? ?f? g h"} + +set i 1 +foreach {args result} { + {1 2 3 4} {a 1 b 2 c _c d _d e _e f _f g 3 h 4 args {}} + {1 2 3 4 5} {a 1 b 2 c 3 d _d e _e f _f g 4 h 5 args {}} + {1 2 3 4 5 6} {a 1 b 2 c 3 d 4 e _e f _f g 5 h 6 args {}} + {1 2 3 4 5 6 7} {a 1 b 2 c 3 d 4 e _e f 5 g 6 h 7 args {}} + {1 2 3 4 5 6 7 8} {a 1 b 2 c 3 d 4 e 5 f 6 g 7 h 8 args {}} + {1 2 3 4 5 6 7 8 9} {a 1 b 2 c 3 d 4 e 6 f 7 g 8 h 9 args 5} + {1 2 3 4 5 6 7 8 9 0} {a 1 b 2 c 3 d 4 e 7 f 8 g 9 h 0 args {5 6}} +} { + test tip288-2.[incr i] {Pathological arglist} -setup $setup -cleanup $cleanup -body [ + list x {*}$args + ] -result [list {*}$result] +} + +set setup { + proc stup {{chan stdout} text} { + list chan $chan text $text + } +} +set cleanup {rename stup {}} +set i 0 +foreach {args code result} { + {} error {wrong # args: should be "stup ?chan? text"} + {foo} ok {chan stdout text foo} + {foo bar} ok {chan foo text bar} + {foo bar baz} error {wrong # args: should be "stup ?chan? text"} +} { + test tip288-3.[incr i] {Pathological arglist} -setup $setup -cleanup $cleanup -body [ + list stup {*}$args + ] -returnCodes $code -result $result +}