Tcl Source Code

If \fIname\fR includes any namespace qualifiers,
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
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.
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.
Arguments with default values that are followed by non-defaulted
arguments become required arguments; enough actual arguments must be
Required arguments may only be in the beginning and in the end of the argument list,
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.
surrounding any optional 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.
.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,
\fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands.
The current namespace when \fIbody\fR is executed will be the

    Interp *iPtr = (Interp *) interp;

    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
	 * compiled, and it is not shared with anyone else, so it's OK not to
	 * unshare it (as a matter of fact, it is bad to unshare it, because

		    "argument with no name", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "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.
	 */

	argnamei = argname;
	argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;

			"default value inconsistent with precompiled body", -1);
		    Tcl_SetObjResult(interp, errorObj);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "BYTECODELIES", NULL);
		    goto procError;
		}
	    }
	    if ((i == numArgs - 1)
	    if (isArgs) {
		    && (localPtr->nameLength == 4)
		    && (localPtr->name[0] == 'a')
		    && (strcmp(localPtr->name, "args") == 0)) {
		localPtr->flags |= VAR_IS_ARGS;
	    }

	    localPtr = localPtr->nextPtr;
	} else {
	    /*
	     * Allocate an entry in the runtime procedure frame's array of

	    if (fieldCount == 2) {
		localPtr->defValuePtr = fieldValues[1];
		Tcl_IncrRefCount(localPtr->defValuePtr);
	    } else {
		localPtr->defValuePtr = NULL;
	    }
	    memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
	    if ((i == numArgs - 1)
	    if (isArgs) {
		    && (localPtr->nameLength == 4)
		    && (localPtr->name[0] == 'a')
		    && (memcmp(localPtr->name, "args", 4) == 0)) {
		localPtr->flags |= VAR_IS_ARGS;
	    }
	}
    }

    *procPtrPtr = procPtr;
    return TCL_OK;

static int
ProcWrongNumArgs(
    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];
    }
    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 ; i<i2 ; i++) {
	Tcl_DecrRefCount(desiredObjs[i]);
    }
    TclStackFree(interp, desiredObjs);
    return TCL_ERROR;
}

/*

				 * invoked. */
    int skip)			/* Number of initial arguments to be skipped,
				 * i.e., words in the "command name". */
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    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
    nextArgObj = framePtr->objv + skip;
					 * procedure. */
    if (numArgs == 0) {
	if (argCt) {
	    goto incorrectArgs;
	} else {
	    goto correctArgs;
	}
    }
    argObjs = framePtr->objv + skip;
    imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
    lastArgObj = &nextArgObj[argCt-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;
     * 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
	 * last formal is special.
	 */
     */
    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. */

	Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL;

	if (!objPtr) {
	    goto incorrectArgs;
	--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;
	varPtr->flags = 0;
	nextVarPtr->flags = 0;
	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);	/* Local var reference. */
    }

	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */

	++nextVarPtr; ++nextDefPtr;
    }
    /*
     * When we get here, the last formal argument remains to be defined:
     * Optional args, RHS
     * defPtr and varPtr point to the last argument to be initialized.
     */
    while ( (nextVarPtr <= lastVarPtr)
	 && !(lastDefPtr->flags & VAR_IS_ARGS) ) {
	Tcl_Obj * objPtr;
	if (nextArgObj > lastArgObj) {
	    objPtr = lastDefPtr->value.objPtr;	/* take default */
	} else {
	    objPtr = *(lastArgObj--);

    varPtr->flags = 0;
    if (defPtr && defPtr->flags & VAR_IS_ARGS) {
	}
	if (objPtr == NULL) Tcl_Panic("oops RHS!");
	lastVarPtr->value.objPtr = objPtr;
	lastVarPtr->flags = 0;
	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */

	Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i);

	--lastVarPtr; --lastDefPtr;
    }
	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;
    /*
     * Args?
     */
    if (nextVarPtr < lastVarPtr) {
	Tcl_Panic("nextVarPtr < lastVarPtr!\n");
    }
    if (nextVarPtr == lastVarPtr) {
	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. */
	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;
    }
	    goto incorrectArgs;
	}
    varPtr++;
    }

    /*
     * 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;

    /*
     * Initialise all compiled locals to avoid problems at DeleteLocalVars.
     */

  incorrectArgs:
    if ((skip != 1) &&
	    TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) {
	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
    }
    /*
     * Ensure all un-assigned vars are zeroed
     */
    memset(varPtr, 0,
	    ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
    memset(nextVarPtr, 0,
	    ((framePtr->compiledLocals + numLocals)-nextVarPtr) * sizeof(Var));
    return ProcWrongNumArgs(interp, skip);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushProcCallFrame --

} {11 y-default z-default}
test proc-old-30.7 {arguments and defaults} {
    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
    proc tproc {x {y y-default} z} {
        return [list $x $y $z]
    }
    tproc 2 3
} {2 y-default 3}
} {1 {wrong # args: should be "tproc x ?y? z"}}
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
} {2 3 {4 5}}
test proc-old-30.10 {arguments and defaults} {

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
}