Tcl Source Code

	localPtr = procPtr->firstLocalPtr;
    } else {
	procPtr->numArgs = numArgs;
	procPtr->numCompiledLocals = numArgs;
    }

    for (i = 0; i < numArgs; i++) {
	int fieldCount, nameLength, valueLength, varFlags = 0;
	const char **fieldValues, *varName;

	/*
	 * Now divide the specifier up into name and default.
	 */

	result = Tcl_SplitList(interp, argArray[i], &fieldCount,
		&fieldValues);
	if (result != TCL_OK) {
	    goto procError;
	}
        varName = fieldValues[0];
	if (fieldCount > 2) {
	    ckfree(fieldValues);
	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		    "too many fields in argument specifier \"%s\"",
		    argArray[i]));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}
	if ((fieldCount == 0) || (*varName == 0)) {
	    ckfree(fieldValues);
	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
		    "argument with no name", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}

	nameLength = strlen(varName);
	if (fieldCount == 2) {
	    valueLength = strlen(fieldValues[1]);
	} else {
	    valueLength = 0;
	}

	/*
	 * Check that the formal parameter name is a scalar.
	 */

	p = varName;
	while (*p != '\0') {
	    if (*p == '(') {
		const char *q = p;
		do {
		    q++;
		} while (*q != '\0');
		q--;

		ckfree(fieldValues);
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"FORMALARGUMENTFORMAT", NULL);
		goto procError;
	    }
	    p++;
	}

        if ((i == numArgs - 1)
                && (nameLength == 4)
                && (*varName == 'a')
                && (strcmp(varName, "args") == 0)) {
            varFlags |= VAR_IS_ARGS;
        } else if (*varName == '*' && nameLength > 1) {
            /*
             * Names that begin with an asterisk shall be handled as a link
             * var to be linked at some point in the future.
             */

            if (fieldCount == 2) {
                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                        "procedure \"%s\": formal parameter \"%s\" "
                        " is to be a link and can't have a default value",
                        procName, fieldValues[0]));
                ckfree(fieldValues);
                Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
                        "FORMALARGUMENTFORMAT", NULL);
                goto procError;
            } else {
                varName++;
                nameLength--;

                /*
                 * Indicate this argument is to be a future link var. Does
                 * there need to be a new VAR_FUTURE_LINK flag?
                 */

                varFlags |= VAR_LINK;
            }
        }

	if (precompiled) {
	    /*
	     * Compare the parsed argument with the stored one. Note that the
	     * only flag value that makes sense at this point is VAR_ARGUMENT
	     * (its value was kept the same as pre VarReform to simplify
	     * tbcload's processing of older byetcodes).
	     *
	     * The only other flag value that is important to retrieve from
	     * precompiled procs is VAR_TEMPORARY (also unchanged). It is
	     * needed later when retrieving the variable names.
	     */

	    if ((localPtr->nameLength != nameLength)
		    || (strcmp(localPtr->name, varName))
		    || (localPtr->frameIndex != i)
		    || !(localPtr->flags & VAR_ARGUMENT)
		    || (localPtr->defValuePtr == NULL && fieldCount == 2)
		    || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
			"procedure \"%s\": formal parameter %d is "
			"inconsistent with precompiled body", procName, i));

			    procName, fieldValues[0]));
		    ckfree(fieldValues);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "BYTECODELIES", NULL);
		    goto procError;
		}
	    }




            /*
             * Set the VAR_IS_ARGS flag, etc, if needed.
             */
             
            if (varFlags) {
                localPtr->flags |= varFlags;
            }
	    localPtr = localPtr->nextPtr;
	} else {


            /*
             * Allocate an entry in the runtime procedure frame's array of
             * local variables for the argument.
             */

            localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
            if (procPtr->firstLocalPtr == NULL) {
                procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
            } else {
                procPtr->lastLocalPtr->nextPtr = localPtr;
                procPtr->lastLocalPtr = localPtr;
            }





























            localPtr->nextPtr = NULL;
            localPtr->nameLength = nameLength;
            localPtr->frameIndex = i;
	    localPtr->flags = (varFlags | VAR_ARGUMENT);
            localPtr->resolveInfo = NULL;

            if (fieldCount == 2) {
                localPtr->defValuePtr =
                        Tcl_NewStringObj(fieldValues[1], valueLength);
                Tcl_IncrRefCount(localPtr->defValuePtr);
            } else {
                localPtr->defValuePtr = NULL;
            }
            memcpy(localPtr->name, varName, nameLength + 1);





        }


	ckfree(fieldValues);
    }

    *procPtrPtr = procPtr;
    ckfree(argArray);
    return TCL_OK;

 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Allocates memory on the stack for the compiled local variables, the
 *	caller is responsible for freeing them. Initialises all variables. May
 *	invoke various name resolvers in order to determine which variables
 *	are being referenced at runtime. Links variables for the caller when
 *      a formal parameter has the VAR_LINK flag.
 *
 *----------------------------------------------------------------------
 */

static int
InitArgsAndLocals(
    register Tcl_Interp *interp,/* Interpreter in which procedure was
				 * invoked. */
    Tcl_Obj *procNameObj,	/* Procedure name for error reporting. */
    int skip)			/* Number of initial arguments to be skipped,
				 * i.e., words in the "command name". */
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    register Proc *procPtr = framePtr->procPtr;
    ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
    register Var *varPtr, *defPtr;
    int localCt = procPtr->numCompiledLocals, numArgs, argCt, imax, i = 0;
    Tcl_Obj *const *argObjs;

    /*
     * Make sure that the local cache of variable names and initial values has
     * been initialised properly .
     */

	if (argCt) {
	    goto incorrectArgs;
	} else {
	    goto correctArgs;
	}
    }

    /*
     * If the command has any formals with the VAR_LINK flag then
     * cmdPtr->flags will have CMD_HAS_ARG_LINKS. Walk through the
     * the proc's local variable list and set things up as needed.
     */

    if (procPtr->cmdPtr->flags & CMD_HAS_ARG_LINKS) {
	CallFrame *upFramePtr = NULL;
	Var *otherPtr, *arrayPtr;
	CompiledLocal *localPtr = procPtr->firstLocalPtr;
	int done = 1;  

	imax = ((argCt < numArgs) ? argCt : numArgs);
	for (; i < imax; i++, localPtr = localPtr->nextPtr,
		varPtr++, defPtr ? defPtr++ : defPtr) {
	    Tcl_Obj *objPtr = argObjs[i];

            /*
             * Now check if this formal was defined to be linked to its
             * corresponding argument. The formal doesn't do
             * any linking itself.
             */

	    if (TclIsVarLink(localPtr)) {
		if (upFramePtr == NULL) {
		    if (TclObjGetFrame(interp, NULL, &upFramePtr) == -1) {
                        i = -1;    /* Tell incorrectArgs we set the error */
			goto incorrectArgs;
		    }
		}

		/*
		 * Locate the other variable.
		 */

		((Interp *)interp)->varFramePtr = upFramePtr;
		otherPtr = TclObjLookupVarEx(interp, objPtr, NULL,
			TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1,
			/*createPart2*/ 1, &arrayPtr);
		((Interp *)interp)->varFramePtr = framePtr;
		if (otherPtr == NULL) {
                    i = -1;    /* Tell incorrectArgs we set the error */
		    goto incorrectArgs;
		}

		varPtr->flags = VAR_LINK;
		varPtr->value.linkPtr = otherPtr;
		if (TclIsVarInHash(otherPtr)) {
		    VarHashRefCount(otherPtr)++;
		}
	    } else if (i != numArgs-1) {
		varPtr->flags = 0;
		varPtr->value.objPtr = objPtr;
		Tcl_IncrRefCount(objPtr);	/* Local var is a reference */
	    } else {

		/*
		 * The last non-linked formal could be 'args'. Let the 'args'
                 * checking code handle it.
		 */

		done = 0;
		break;
	    }
	}

        /*
         * These tests are true only when all arguments are provided by the
         * caller and there is no formal 'args'.
         */

	if (done && argCt == numArgs) {
	    goto correctArgs;
	}
    } else {
	imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
	for (; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
	    /*
	     * "Normal" arguments; last formal is special, depends on it being
	     * 'args'.
	     */

	    Tcl_Obj *objPtr = argObjs[i];

  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));
    return (i != -1 ? ProcWrongNumArgs(interp, skip) : TCL_ERROR);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushProcCallFrame --
 *

} {}
test oo-35.4 {Bug 593baa032c: mixins list teardown} {
    # Bug makes this crash, especially with mem-debugging on
    oo::class create B {}
    oo::class create D {mixin B}
    namespace eval [info object namespace D] [list [namespace which B] destroy]
} {}

test oo-36.1 {OO: Auto linking} -setup {
    oo::class create C
} -body {
    oo::define C {
        constructor {*a} {
            incr a
            lappend ::result $a
        }
        method m {*a} {
            incr a
            lappend ::result $a
        }
    }
    set a 0
    set c [C new a]
    $c m a
    return $result
} -cleanup {
    C destroy
} -result {1 2}


cleanupTests
return

# Local Variables:
# mode: tcl

    lappend lambda {set a 1}
    interp create slave
    slave eval [list apply $lambda foo]
    interp delete slave
    unset lambda
} {}

test proc-8.1 {Auto argument linking} -body {
    proc P {*a} {
        set a 1
        return
    }
    apply {{} {
        set a {}
        P a
        set a
    }}
} -cleanup {
    rename P {}
} -result 1

test proc-8.2 {Auto argument linking, multiple} -body {
    proc P {*a *b} {
        set a 1
        set b 2
        return
    }
    apply {{} {
        set a {}
        set b {}
        P a b
        set b
    }}
} -cleanup {
    rename P {}
} -result 2

test proc-8.3 {Auto argument linking, multiple of same} -body {
    proc P {*a *a} {
        set a 1
        return
    }
    apply {{} {
        set a {}
        P a a
        set a
    }}
} -cleanup {
    rename P {}
} -result 1

test proc-8.4 {Auto argument linking, and defaults} -body {
    proc P {*a {foo bar} args} {
        return $foo
    }
    apply {{} {
        set a {}
        P a
    }}
} -cleanup {
    rename P {}
} -result {bar}

test proc-8.5 {Auto argument linking, and args} -body {
    proc P {*a args} {
        return [lindex $args 0]
    }
    apply {{} {
        set a {}
        P a foo
    }}
} -cleanup {
    rename P {}
} -result {foo}

test proc-8.6 {Auto argument linking, chain linking} -body {
    proc P {*a} {
        P2 a
    }
    proc P2 {*a} {
        incr a
    }
    apply {{} {
        P a
        set a
    }}
} -cleanup {
    rename P {}
    rename P2 {}
} -result {1}

test proc-8.7 {Auto argument linking, create var in caller} -body {
    proc P {*a} {
        incr a
    }
    apply {{} {
        P a
        set a
    }}
} -cleanup {
    rename P {}
} -result {1}

test proc-8.8 {Auto argument linking, default for auto-link formal} -body {
    proc P {{*a b}} {
        incr a
    }
    apply {{} {
        set a 0
        P a
    }}
} -constraints procbodytest -returnCodes error -cleanup {
    catch {rename P {}}
} -result {procedure "P": formal parameter "*a"  is to be a link and can't have a default value}

test proc-8.9 {Auto argument linking, bad variable} -body {
    proc P {*a} {
        incr a
    }
    P mumbo::jumbo
} -constraints procbodytest -returnCodes error -cleanup {
    catch {rename P {}}
} -result {can't access "mumbo::jumbo": parent namespace doesn't exist}


# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return