Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclProc.c@260cb5ec6c19 (annotated)

sl@0	1	/*
sl@0	2	* tclProc.c --
sl@0	3	*
sl@0	4	* This file contains routines that implement Tcl procedures,
sl@0	5	* including the "proc" and "uplevel" commands.
sl@0	6	*
sl@0	7	* Copyright (c) 1987-1993 The Regents of the University of California.
sl@0	8	* Copyright (c) 1994-1998 Sun Microsystems, Inc.
sl@0	9	* Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
sl@0	10	*
sl@0	11	* See the file "license.terms" for information on usage and redistribution
sl@0	12	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0	13	*
sl@0	14	* RCS: @(#) $Id: tclProc.c,v 1.44.2.6 2006/11/28 22:20:02 andreas_kupries Exp $
sl@0	15	*/
sl@0	16
sl@0	17	#include "tclInt.h"
sl@0	18	#include "tclCompile.h"
sl@0	19
sl@0	20	/*
sl@0	21	* Prototypes for static functions in this file
sl@0	22	*/
sl@0	23
sl@0	24	static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj srcPtr, Tcl_Obj dupPtr));
sl@0	25	static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0	26	static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	27	Tcl_Obj *objPtr));
sl@0	28	static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
sl@0	29	static int ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	30	Proc procPtr, Tcl_Obj bodyPtr, Namespace *nsPtr,
sl@0	31	CONST char description, CONST char procName,
sl@0	32	Proc **procPtrPtr));
sl@0	33	static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	34	char *procName, int nameLen, int returnCode));
sl@0	35	static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	36	Tcl_Parse parsePtr, struct CompileEnv envPtr));
sl@0	37
sl@0	38	/*
sl@0	39	* The ProcBodyObjType type
sl@0	40	*/
sl@0	41
sl@0	42	Tcl_ObjType tclProcBodyType = {
sl@0	43	"procbody", /* name for this type */
sl@0	44	ProcBodyFree, /* FreeInternalRep procedure */
sl@0	45	ProcBodyDup, /* DupInternalRep procedure */
sl@0	46	ProcBodyUpdateString, /* UpdateString procedure */
sl@0	47	ProcBodySetFromAny /* SetFromAny procedure */
sl@0	48	};
sl@0	49
sl@0	50	/*
sl@0	51	*----------------------------------------------------------------------
sl@0	52	*
sl@0	53	* Tcl_ProcObjCmd --
sl@0	54	*
sl@0	55	* This object-based procedure is invoked to process the "proc" Tcl
sl@0	56	* command. See the user documentation for details on what it does.
sl@0	57	*
sl@0	58	* Results:
sl@0	59	* A standard Tcl object result value.
sl@0	60	*
sl@0	61	* Side effects:
sl@0	62	* A new procedure gets created.
sl@0	63	*
sl@0	64	*----------------------------------------------------------------------
sl@0	65	*/
sl@0	66
sl@0	67	/* ARGSUSED */
sl@0	68	EXPORT_C int
sl@0	69	Tcl_ProcObjCmd(dummy, interp, objc, objv)
sl@0	70	ClientData dummy; /* Not used. */
sl@0	71	Tcl_Interp interp; / Current interpreter. */
sl@0	72	int objc; /* Number of arguments. */
sl@0	73	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	74	{
sl@0	75	register Interp iPtr = (Interp ) interp;
sl@0	76	Proc *procPtr;
sl@0	77	char *fullName;
sl@0	78	CONST char procName, procArgs, *procBody;
sl@0	79	Namespace nsPtr, altNsPtr, *cxtNsPtr;
sl@0	80	Tcl_Command cmd;
sl@0	81	Tcl_DString ds;
sl@0	82
sl@0	83	if (objc != 4) {
sl@0	84	Tcl_WrongNumArgs(interp, 1, objv, "name args body");
sl@0	85	return TCL_ERROR;
sl@0	86	}
sl@0	87
sl@0	88	/*
sl@0	89	* Determine the namespace where the procedure should reside. Unless
sl@0	90	* the command name includes namespace qualifiers, this will be the
sl@0	91	* current namespace.
sl@0	92	*/
sl@0	93
sl@0	94	fullName = TclGetString(objv[1]);
sl@0	95	TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
sl@0	96	0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
sl@0	97
sl@0	98	if (nsPtr == NULL) {
sl@0	99	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	100	"can't create procedure \"", fullName,
sl@0	101	"\": unknown namespace", (char *) NULL);
sl@0	102	return TCL_ERROR;
sl@0	103	}
sl@0	104	if (procName == NULL) {
sl@0	105	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	106	"can't create procedure \"", fullName,
sl@0	107	"\": bad procedure name", (char *) NULL);
sl@0	108	return TCL_ERROR;
sl@0	109	}
sl@0	110	if ((nsPtr != iPtr->globalNsPtr)
sl@0	111	&& (procName != NULL) && (procName[0] == ':')) {
sl@0	112	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	113	"can't create procedure \"", procName,
sl@0	114	"\" in non-global namespace with name starting with \":\"",
sl@0	115	(char *) NULL);
sl@0	116	return TCL_ERROR;
sl@0	117	}
sl@0	118
sl@0	119	/*
sl@0	120	* Create the data structure to represent the procedure.
sl@0	121	*/
sl@0	122	if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
sl@0	123	&procPtr) != TCL_OK) {
sl@0	124	return TCL_ERROR;
sl@0	125	}
sl@0	126
sl@0	127	/*
sl@0	128	* Now create a command for the procedure. This will initially be in
sl@0	129	* the current namespace unless the procedure's name included namespace
sl@0	130	* qualifiers. To create the new command in the right namespace, we
sl@0	131	* generate a fully qualified name for it.
sl@0	132	*/
sl@0	133
sl@0	134	Tcl_DStringInit(&ds);
sl@0	135	if (nsPtr != iPtr->globalNsPtr) {
sl@0	136	Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
sl@0	137	Tcl_DStringAppend(&ds, "::", 2);
sl@0	138	}
sl@0	139	Tcl_DStringAppend(&ds, procName, -1);
sl@0	140
sl@0	141	Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
sl@0	142	(ClientData) procPtr, TclProcDeleteProc);
sl@0	143	cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
sl@0	144	TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
sl@0	145
sl@0	146	Tcl_DStringFree(&ds);
sl@0	147	/*
sl@0	148	* Now initialize the new procedure's cmdPtr field. This will be used
sl@0	149	* later when the procedure is called to determine what namespace the
sl@0	150	* procedure will run in. This will be different than the current
sl@0	151	* namespace if the proc was renamed into a different namespace.
sl@0	152	*/
sl@0	153
sl@0	154	procPtr->cmdPtr = (Command *) cmd;
sl@0	155
sl@0	156	#ifdef TCL_TIP280
sl@0	157	/* TIP #280 Remember the line the procedure body is starting on. In a
sl@0	158	* Byte code context we ask the engine to provide us with the necessary
sl@0	159	* information. This is for the initialization of the byte code compiler
sl@0	160	* when the body is used for the first time.
sl@0	161	*/
sl@0	162
sl@0	163	if (iPtr->cmdFramePtr) {
sl@0	164	CmdFrame context = *iPtr->cmdFramePtr;
sl@0	165
sl@0	166	if (context.type == TCL_LOCATION_BC) {
sl@0	167	TclGetSrcInfoForPc (&context);
sl@0	168	/* May get path in context */
sl@0	169	} else if (context.type == TCL_LOCATION_SOURCE) {
sl@0	170	/* context now holds another reference */
sl@0	171	Tcl_IncrRefCount (context.data.eval.path);
sl@0	172	}
sl@0	173
sl@0	174	/* type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We
sl@0	175	* cannot assume that 'line' is valid here, we have to check. If the
sl@0	176	* outer context is an eval (bc, prebc, eval) we do not save any
sl@0	177	* information. Counting relative to the beginning of the proc body is
sl@0	178	* more sensible than counting relative to the outer eval block.
sl@0	179	*/
sl@0	180
sl@0	181	if ((context.type == TCL_LOCATION_SOURCE) &&
sl@0	182	context.line &&
sl@0	183	(context.nline >= 4) &&
sl@0	184	(context.line [3] >= 0)) {
sl@0	185	int new;
sl@0	186	CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
sl@0	187
sl@0	188	cfPtr->level = -1;
sl@0	189	cfPtr->type = context.type;
sl@0	190	cfPtr->line = (int*) ckalloc (sizeof (int));
sl@0	191	cfPtr->line [0] = context.line [3];
sl@0	192	cfPtr->nline = 1;
sl@0	193	cfPtr->framePtr = NULL;
sl@0	194	cfPtr->nextPtr = NULL;
sl@0	195
sl@0	196	if (context.type == TCL_LOCATION_SOURCE) {
sl@0	197	cfPtr->data.eval.path = context.data.eval.path;
sl@0	198	/* Transfer of reference. The reference going away (release of
sl@0	199	* the context) is replaced by the reference in the
sl@0	200	* constructed cmdframe */
sl@0	201	} else {
sl@0	202	cfPtr->type = TCL_LOCATION_EVAL;
sl@0	203	cfPtr->data.eval.path = NULL;
sl@0	204	}
sl@0	205
sl@0	206	cfPtr->cmd.str.cmd = NULL;
sl@0	207	cfPtr->cmd.str.len = 0;
sl@0	208
sl@0	209	Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr,
sl@0	210	(char*) procPtr, &new),
sl@0	211	cfPtr);
sl@0	212	}
sl@0	213	}
sl@0	214	#endif
sl@0	215
sl@0	216	/*
sl@0	217	* Optimize for noop procs: if the body is not precompiled (like a TclPro
sl@0	218	* procbody), and the argument list is just "args" and the body is empty,
sl@0	219	* define a compileProc to compile a noop.
sl@0	220	*
sl@0	221	* Notes:
sl@0	222	* - cannot be done for any argument list without having different
sl@0	223	* compiled/not-compiled behaviour in the "wrong argument #" case,
sl@0	224	* or making this code much more complicated. In any case, it doesn't
sl@0	225	* seem to make a lot of sense to verify the number of arguments we
sl@0	226	* are about to ignore ...
sl@0	227	* - could be enhanced to handle also non-empty bodies that contain
sl@0	228	* only comments; however, parsing the body will slow down the
sl@0	229	* compilation of all procs whose argument list is just _args_ */
sl@0	230
sl@0	231	if (objv[3]->typePtr == &tclProcBodyType) {
sl@0	232	goto done;
sl@0	233	}
sl@0	234
sl@0	235	procArgs = Tcl_GetString(objv[2]);
sl@0	236
sl@0	237	while (*procArgs == ' ') {
sl@0	238	procArgs++;
sl@0	239	}
sl@0	240
sl@0	241	if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
sl@0	242	procArgs +=4;
sl@0	243	while(*procArgs != '\0') {
sl@0	244	if (*procArgs != ' ') {
sl@0	245	goto done;
sl@0	246	}
sl@0	247	procArgs++;
sl@0	248	}
sl@0	249
sl@0	250	/*
sl@0	251	* The argument list is just "args"; check the body
sl@0	252	*/
sl@0	253
sl@0	254	procBody = Tcl_GetString(objv[3]);
sl@0	255	while (*procBody != '\0') {
sl@0	256	if (!isspace(UCHAR(*procBody))) {
sl@0	257	goto done;
sl@0	258	}
sl@0	259	procBody++;
sl@0	260	}
sl@0	261
sl@0	262	/*
sl@0	263	* The body is just spaces: link the compileProc
sl@0	264	*/
sl@0	265
sl@0	266	((Command *) cmd)->compileProc = TclCompileNoOp;
sl@0	267	}
sl@0	268
sl@0	269	done:
sl@0	270	return TCL_OK;
sl@0	271	}
sl@0	272
sl@0	273	/*
sl@0	274	*----------------------------------------------------------------------
sl@0	275	*
sl@0	276	* TclCreateProc --
sl@0	277	*
sl@0	278	* Creates the data associated with a Tcl procedure definition.
sl@0	279	* This procedure knows how to handle two types of body objects:
sl@0	280	* strings and procbody. Strings are the traditional (and common) value
sl@0	281	* for bodies, procbody are values created by extensions that have
sl@0	282	* loaded a previously compiled script.
sl@0	283	*
sl@0	284	* Results:
sl@0	285	* Returns TCL_OK on success, along with a pointer to a Tcl
sl@0	286	* procedure definition in procPtrPtr. This definition should
sl@0	287	* be freed by calling TclCleanupProc() when it is no longer
sl@0	288	* needed. Returns TCL_ERROR if anything goes wrong.
sl@0	289	*
sl@0	290	* Side effects:
sl@0	291	* If anything goes wrong, this procedure returns an error
sl@0	292	* message in the interpreter.
sl@0	293	*
sl@0	294	*----------------------------------------------------------------------
sl@0	295	*/
sl@0	296	int
sl@0	297	TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
sl@0	298	Tcl_Interp interp; / interpreter containing proc */
sl@0	299	Namespace nsPtr; / namespace containing this proc */
sl@0	300	CONST char procName; / unqualified name of this proc */
sl@0	301	Tcl_Obj argsPtr; / description of arguments */
sl@0	302	Tcl_Obj bodyPtr; / command body */
sl@0	303	Proc *procPtrPtr; / returns: pointer to proc data */
sl@0	304	{
sl@0	305	Interp iPtr = (Interp)interp;
sl@0	306	CONST char **argArray = NULL;
sl@0	307
sl@0	308	register Proc *procPtr;
sl@0	309	int i, length, result, numArgs;
sl@0	310	CONST char args, bytes, *p;
sl@0	311	register CompiledLocal *localPtr = NULL;
sl@0	312	Tcl_Obj *defPtr;
sl@0	313	int precompiled = 0;
sl@0	314
sl@0	315	if (bodyPtr->typePtr == &tclProcBodyType) {
sl@0	316	/*
sl@0	317	* Because the body is a TclProProcBody, the actual body is already
sl@0	318	* compiled, and it is not shared with anyone else, so it's OK not to
sl@0	319	* unshare it (as a matter of fact, it is bad to unshare it, because
sl@0	320	* there may be no source code).
sl@0	321	*
sl@0	322	* We don't create and initialize a Proc structure for the procedure;
sl@0	323	* rather, we use what is in the body object. Note that
sl@0	324	* we initialize its cmdPtr field below after we've created the command
sl@0	325	* for the procedure. We increment the ref count of the Proc struct
sl@0	326	* since the command (soon to be created) will be holding a reference
sl@0	327	* to it.
sl@0	328	*/
sl@0	329
sl@0	330	procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
sl@0	331	procPtr->iPtr = iPtr;
sl@0	332	procPtr->refCount++;
sl@0	333	precompiled = 1;
sl@0	334	} else {
sl@0	335	/*
sl@0	336	* If the procedure's body object is shared because its string value is
sl@0	337	* identical to, e.g., the body of another procedure, we must create a
sl@0	338	* private copy for this procedure to use. Such sharing of procedure
sl@0	339	* bodies is rare but can cause problems. A procedure body is compiled
sl@0	340	* in a context that includes the number of compiler-allocated "slots"
sl@0	341	* for local variables. Each formal parameter is given a local variable
sl@0	342	* slot (the "procPtr->numCompiledLocals = numArgs" assignment
sl@0	343	* below). This means that the same code can not be shared by two
sl@0	344	* procedures that have a different number of arguments, even if their
sl@0	345	* bodies are identical. Note that we don't use Tcl_DuplicateObj since
sl@0	346	* we would not want any bytecode internal representation.
sl@0	347	*/
sl@0	348
sl@0	349	if (Tcl_IsShared(bodyPtr)) {
sl@0	350	bytes = Tcl_GetStringFromObj(bodyPtr, &length);
sl@0	351	bodyPtr = Tcl_NewStringObj(bytes, length);
sl@0	352	}
sl@0	353
sl@0	354	/*
sl@0	355	* Create and initialize a Proc structure for the procedure. Note that
sl@0	356	* we initialize its cmdPtr field below after we've created the command
sl@0	357	* for the procedure. We increment the ref count of the procedure's
sl@0	358	* body object since there will be a reference to it in the Proc
sl@0	359	* structure.
sl@0	360	*/
sl@0	361
sl@0	362	Tcl_IncrRefCount(bodyPtr);
sl@0	363
sl@0	364	procPtr = (Proc *) ckalloc(sizeof(Proc));
sl@0	365	procPtr->iPtr = iPtr;
sl@0	366	procPtr->refCount = 1;
sl@0	367	procPtr->bodyPtr = bodyPtr;
sl@0	368	procPtr->numArgs = 0; /* actual argument count is set below. */
sl@0	369	procPtr->numCompiledLocals = 0;
sl@0	370	procPtr->firstLocalPtr = NULL;
sl@0	371	procPtr->lastLocalPtr = NULL;
sl@0	372	}
sl@0	373
sl@0	374	/*
sl@0	375	* Break up the argument list into argument specifiers, then process
sl@0	376	* each argument specifier.
sl@0	377	* If the body is precompiled, processing is limited to checking that
sl@0	378	* the the parsed argument is consistent with the one stored in the
sl@0	379	* Proc.
sl@0	380	* THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
sl@0	381	*/
sl@0	382
sl@0	383	args = Tcl_GetStringFromObj(argsPtr, &length);
sl@0	384	result = Tcl_SplitList(interp, args, &numArgs, &argArray);
sl@0	385	if (result != TCL_OK) {
sl@0	386	goto procError;
sl@0	387	}
sl@0	388
sl@0	389	if (precompiled) {
sl@0	390	if (numArgs > procPtr->numArgs) {
sl@0	391	char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
sl@0	392	sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
sl@0	393	numArgs, procPtr->numArgs);
sl@0	394	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	395	"procedure \"", procName,
sl@0	396	buf, (char *) NULL);
sl@0	397	goto procError;
sl@0	398	}
sl@0	399	localPtr = procPtr->firstLocalPtr;
sl@0	400	} else {
sl@0	401	procPtr->numArgs = numArgs;
sl@0	402	procPtr->numCompiledLocals = numArgs;
sl@0	403	}
sl@0	404	for (i = 0; i < numArgs; i++) {
sl@0	405	int fieldCount, nameLength, valueLength;
sl@0	406	CONST char **fieldValues;
sl@0	407
sl@0	408	/*
sl@0	409	* Now divide the specifier up into name and default.
sl@0	410	*/
sl@0	411
sl@0	412	result = Tcl_SplitList(interp, argArray[i], &fieldCount,
sl@0	413	&fieldValues);
sl@0	414	if (result != TCL_OK) {
sl@0	415	goto procError;
sl@0	416	}
sl@0	417	if (fieldCount > 2) {
sl@0	418	ckfree((char *) fieldValues);
sl@0	419	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	420	"too many fields in argument specifier \"",
sl@0	421	argArray[i], "\"", (char *) NULL);
sl@0	422	goto procError;
sl@0	423	}
sl@0	424	if ((fieldCount == 0) \|\| (*fieldValues[0] == 0)) {
sl@0	425	ckfree((char *) fieldValues);
sl@0	426	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	427	"procedure \"", procName,
sl@0	428	"\" has argument with no name", (char *) NULL);
sl@0	429	goto procError;
sl@0	430	}
sl@0	431
sl@0	432	nameLength = strlen(fieldValues[0]);
sl@0	433	if (fieldCount == 2) {
sl@0	434	valueLength = strlen(fieldValues[1]);
sl@0	435	} else {
sl@0	436	valueLength = 0;
sl@0	437	}
sl@0	438
sl@0	439	/*
sl@0	440	* Check that the formal parameter name is a scalar.
sl@0	441	*/
sl@0	442
sl@0	443	p = fieldValues[0];
sl@0	444	while (*p != '\0') {
sl@0	445	if (*p == '(') {
sl@0	446	CONST char *q = p;
sl@0	447	do {
sl@0	448	q++;
sl@0	449	} while (*q != '\0');
sl@0	450	q--;
sl@0	451	if (q == ')') { / we have an array element */
sl@0	452	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	453	"procedure \"", procName,
sl@0	454	"\" has formal parameter \"", fieldValues[0],
sl@0	455	"\" that is an array element",
sl@0	456	(char *) NULL);
sl@0	457	ckfree((char *) fieldValues);
sl@0	458	goto procError;
sl@0	459	}
sl@0	460	} else if ((p == ':') && ((p+1) == ':')) {
sl@0	461	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	462	"procedure \"", procName,
sl@0	463	"\" has formal parameter \"", fieldValues[0],
sl@0	464	"\" that is not a simple name",
sl@0	465	(char *) NULL);
sl@0	466	ckfree((char *) fieldValues);
sl@0	467	goto procError;
sl@0	468	}
sl@0	469	p++;
sl@0	470	}
sl@0	471
sl@0	472	if (precompiled) {
sl@0	473	/*
sl@0	474	* Compare the parsed argument with the stored one.
sl@0	475	* For the flags, we and out VAR_UNDEFINED to support bridging
sl@0	476	* precompiled <= 8.3 code in 8.4 where this is now used as an
sl@0	477	* optimization indicator. Yes, this is a hack. -- hobbs
sl@0	478	*/
sl@0	479
sl@0	480	if ((localPtr->nameLength != nameLength)
sl@0	481	\|\| (strcmp(localPtr->name, fieldValues[0]))
sl@0	482	\|\| (localPtr->frameIndex != i)
sl@0	483	\|\| ((localPtr->flags & ~VAR_UNDEFINED)
sl@0	484	!= (VAR_SCALAR \| VAR_ARGUMENT))
sl@0	485	\|\| ((localPtr->defValuePtr == NULL)
sl@0	486	&& (fieldCount == 2))
sl@0	487	\|\| ((localPtr->defValuePtr != NULL)
sl@0	488	&& (fieldCount != 2))) {
sl@0	489	char buf[80 + TCL_INTEGER_SPACE];
sl@0	490	sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
sl@0	491	i);
sl@0	492	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	493	"procedure \"", procName,
sl@0	494	buf, (char *) NULL);
sl@0	495	ckfree((char *) fieldValues);
sl@0	496	goto procError;
sl@0	497	}
sl@0	498
sl@0	499	/*
sl@0	500	* compare the default value if any
sl@0	501	*/
sl@0	502
sl@0	503	if (localPtr->defValuePtr != NULL) {
sl@0	504	int tmpLength;
sl@0	505	char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
sl@0	506	&tmpLength);
sl@0	507	if ((valueLength != tmpLength)
sl@0	508	\|\| (strncmp(fieldValues[1], tmpPtr,
sl@0	509	(size_t) tmpLength))) {
sl@0	510	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
sl@0	511	"procedure \"", procName,
sl@0	512	"\": formal parameter \"",
sl@0	513	fieldValues[0],
sl@0	514	"\" has default value inconsistent with precompiled body",
sl@0	515	(char *) NULL);
sl@0	516	ckfree((char *) fieldValues);
sl@0	517	goto procError;
sl@0	518	}
sl@0	519	}
sl@0	520
sl@0	521	localPtr = localPtr->nextPtr;
sl@0	522	} else {
sl@0	523	/*
sl@0	524	* Allocate an entry in the runtime procedure frame's array of
sl@0	525	* local variables for the argument.
sl@0	526	*/
sl@0	527
sl@0	528	localPtr = (CompiledLocal *) ckalloc((unsigned)
sl@0	529	(sizeof(CompiledLocal) - sizeof(localPtr->name)
sl@0	530	+ nameLength+1));
sl@0	531	if (procPtr->firstLocalPtr == NULL) {
sl@0	532	procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
sl@0	533	} else {
sl@0	534	procPtr->lastLocalPtr->nextPtr = localPtr;
sl@0	535	procPtr->lastLocalPtr = localPtr;
sl@0	536	}
sl@0	537	localPtr->nextPtr = NULL;
sl@0	538	localPtr->nameLength = nameLength;
sl@0	539	localPtr->frameIndex = i;
sl@0	540	localPtr->flags = VAR_SCALAR \| VAR_ARGUMENT;
sl@0	541	localPtr->resolveInfo = NULL;
sl@0	542
sl@0	543	if (fieldCount == 2) {
sl@0	544	localPtr->defValuePtr =
sl@0	545	Tcl_NewStringObj(fieldValues[1], valueLength);
sl@0	546	Tcl_IncrRefCount(localPtr->defValuePtr);
sl@0	547	} else {
sl@0	548	localPtr->defValuePtr = NULL;
sl@0	549	}
sl@0	550	strcpy(localPtr->name, fieldValues[0]);
sl@0	551	}
sl@0	552
sl@0	553	ckfree((char *) fieldValues);
sl@0	554	}
sl@0	555
sl@0	556	/*
sl@0	557	* Now initialize the new procedure's cmdPtr field. This will be used
sl@0	558	* later when the procedure is called to determine what namespace the
sl@0	559	* procedure will run in. This will be different than the current
sl@0	560	* namespace if the proc was renamed into a different namespace.
sl@0	561	*/
sl@0	562
sl@0	563	*procPtrPtr = procPtr;
sl@0	564	ckfree((char *) argArray);
sl@0	565	return TCL_OK;
sl@0	566
sl@0	567	procError:
sl@0	568	if (precompiled) {
sl@0	569	procPtr->refCount--;
sl@0	570	} else {
sl@0	571	Tcl_DecrRefCount(bodyPtr);
sl@0	572	while (procPtr->firstLocalPtr != NULL) {
sl@0	573	localPtr = procPtr->firstLocalPtr;
sl@0	574	procPtr->firstLocalPtr = localPtr->nextPtr;
sl@0	575
sl@0	576	defPtr = localPtr->defValuePtr;
sl@0	577	if (defPtr != NULL) {
sl@0	578	Tcl_DecrRefCount(defPtr);
sl@0	579	}
sl@0	580
sl@0	581	ckfree((char *) localPtr);
sl@0	582	}
sl@0	583	ckfree((char *) procPtr);
sl@0	584	}
sl@0	585	if (argArray != NULL) {
sl@0	586	ckfree((char *) argArray);
sl@0	587	}
sl@0	588	return TCL_ERROR;
sl@0	589	}
sl@0	590
sl@0	591	/*
sl@0	592	*----------------------------------------------------------------------
sl@0	593	*
sl@0	594	* TclGetFrame --
sl@0	595	*
sl@0	596	* Given a description of a procedure frame, such as the first
sl@0	597	* argument to an "uplevel" or "upvar" command, locate the
sl@0	598	* call frame for the appropriate level of procedure.
sl@0	599	*
sl@0	600	* Results:
sl@0	601	* The return value is -1 if an error occurred in finding the frame
sl@0	602	* (in this case an error message is left in the interp's result).
sl@0	603	* 1 is returned if string was either a number or a number preceded
sl@0	604	* by "#" and it specified a valid frame. 0 is returned if string
sl@0	605	* isn't one of the two things above (in this case, the lookup
sl@0	606	* acts as if string were "1"). The variable pointed to by
sl@0	607	* framePtrPtr is filled in with the address of the desired frame
sl@0	608	* (unless an error occurs, in which case it isn't modified).
sl@0	609	*
sl@0	610	* Side effects:
sl@0	611	* None.
sl@0	612	*
sl@0	613	*----------------------------------------------------------------------
sl@0	614	*/
sl@0	615
sl@0	616	int
sl@0	617	TclGetFrame(interp, string, framePtrPtr)
sl@0	618	Tcl_Interp interp; / Interpreter in which to find frame. */
sl@0	619	CONST char string; / String describing frame. */
sl@0	620	CallFrame *framePtrPtr; / Store pointer to frame here (or NULL
sl@0	621	* if global frame indicated). */
sl@0	622	{
sl@0	623	register Interp iPtr = (Interp ) interp;
sl@0	624	int curLevel, level, result;
sl@0	625	CallFrame *framePtr;
sl@0	626
sl@0	627	/*
sl@0	628	* Parse string to figure out which level number to go to.
sl@0	629	*/
sl@0	630
sl@0	631	result = 1;
sl@0	632	curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
sl@0	633	if (*string == '#') {
sl@0	634	if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
sl@0	635	return -1;
sl@0	636	}
sl@0	637	if (level < 0) {
sl@0	638	levelError:
sl@0	639	Tcl_AppendResult(interp, "bad level \"", string, "\"",
sl@0	640	(char *) NULL);
sl@0	641	return -1;
sl@0	642	}
sl@0	643	} else if (isdigit(UCHAR(string))) { / INTL: digit */
sl@0	644	if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
sl@0	645	return -1;
sl@0	646	}
sl@0	647	level = curLevel - level;
sl@0	648	} else {
sl@0	649	level = curLevel - 1;
sl@0	650	result = 0;
sl@0	651	}
sl@0	652
sl@0	653	/*
sl@0	654	* Figure out which frame to use, and modify the interpreter so
sl@0	655	* its variables come from that frame.
sl@0	656	*/
sl@0	657
sl@0	658	if (level == 0) {
sl@0	659	framePtr = NULL;
sl@0	660	} else {
sl@0	661	for (framePtr = iPtr->varFramePtr; framePtr != NULL;
sl@0	662	framePtr = framePtr->callerVarPtr) {
sl@0	663	if (framePtr->level == level) {
sl@0	664	break;
sl@0	665	}
sl@0	666	}
sl@0	667	if (framePtr == NULL) {
sl@0	668	goto levelError;
sl@0	669	}
sl@0	670	}
sl@0	671	*framePtrPtr = framePtr;
sl@0	672	return result;
sl@0	673	}
sl@0	674
sl@0	675	/*
sl@0	676	*----------------------------------------------------------------------
sl@0	677	*
sl@0	678	* Tcl_UplevelObjCmd --
sl@0	679	*
sl@0	680	* This object procedure is invoked to process the "uplevel" Tcl
sl@0	681	* command. See the user documentation for details on what it does.
sl@0	682	*
sl@0	683	* Results:
sl@0	684	* A standard Tcl object result value.
sl@0	685	*
sl@0	686	* Side effects:
sl@0	687	* See the user documentation.
sl@0	688	*
sl@0	689	*----------------------------------------------------------------------
sl@0	690	*/
sl@0	691
sl@0	692	/* ARGSUSED */
sl@0	693	int
sl@0	694	Tcl_UplevelObjCmd(dummy, interp, objc, objv)
sl@0	695	ClientData dummy; /* Not used. */
sl@0	696	Tcl_Interp interp; / Current interpreter. */
sl@0	697	int objc; /* Number of arguments. */
sl@0	698	Tcl_Obj CONST objv[]; / Argument objects. */
sl@0	699	{
sl@0	700	register Interp iPtr = (Interp ) interp;
sl@0	701	char *optLevel;
sl@0	702	int result;
sl@0	703	CallFrame savedVarFramePtr, framePtr;
sl@0	704
sl@0	705	if (objc < 2) {
sl@0	706	uplevelSyntax:
sl@0	707	Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
sl@0	708	return TCL_ERROR;
sl@0	709	}
sl@0	710
sl@0	711	/*
sl@0	712	* Find the level to use for executing the command.
sl@0	713	*/
sl@0	714
sl@0	715	optLevel = TclGetString(objv[1]);
sl@0	716	result = TclGetFrame(interp, optLevel, &framePtr);
sl@0	717	if (result == -1) {
sl@0	718	return TCL_ERROR;
sl@0	719	}
sl@0	720	objc -= (result+1);
sl@0	721	if (objc == 0) {
sl@0	722	goto uplevelSyntax;
sl@0	723	}
sl@0	724	objv += (result+1);
sl@0	725
sl@0	726	/*
sl@0	727	* Modify the interpreter state to execute in the given frame.
sl@0	728	*/
sl@0	729
sl@0	730	savedVarFramePtr = iPtr->varFramePtr;
sl@0	731	iPtr->varFramePtr = framePtr;
sl@0	732
sl@0	733	/*
sl@0	734	* Execute the residual arguments as a command.
sl@0	735	*/
sl@0	736
sl@0	737	if (objc == 1) {
sl@0	738	result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
sl@0	739	} else {
sl@0	740	/*
sl@0	741	* More than one argument: concatenate them together with spaces
sl@0	742	* between, then evaluate the result. Tcl_EvalObjEx will delete
sl@0	743	* the object when it decrements its refcount after eval'ing it.
sl@0	744	*/
sl@0	745	Tcl_Obj *objPtr;
sl@0	746
sl@0	747	objPtr = Tcl_ConcatObj(objc, objv);
sl@0	748	result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
sl@0	749	}
sl@0	750	if (result == TCL_ERROR) {
sl@0	751	char msg[32 + TCL_INTEGER_SPACE];
sl@0	752	sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
sl@0	753	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	754	}
sl@0	755
sl@0	756	/*
sl@0	757	* Restore the variable frame, and return.
sl@0	758	*/
sl@0	759
sl@0	760	iPtr->varFramePtr = savedVarFramePtr;
sl@0	761	return result;
sl@0	762	}
sl@0	763
sl@0	764	/*
sl@0	765	*----------------------------------------------------------------------
sl@0	766	*
sl@0	767	* TclFindProc --
sl@0	768	*
sl@0	769	* Given the name of a procedure, return a pointer to the
sl@0	770	* record describing the procedure. The procedure will be
sl@0	771	* looked up using the usual rules: first in the current
sl@0	772	* namespace and then in the global namespace.
sl@0	773	*
sl@0	774	* Results:
sl@0	775	* NULL is returned if the name doesn't correspond to any
sl@0	776	* procedure. Otherwise, the return value is a pointer to
sl@0	777	* the procedure's record. If the name is found but refers
sl@0	778	* to an imported command that points to a "real" procedure
sl@0	779	* defined in another namespace, a pointer to that "real"
sl@0	780	* procedure's structure is returned.
sl@0	781	*
sl@0	782	* Side effects:
sl@0	783	* None.
sl@0	784	*
sl@0	785	*----------------------------------------------------------------------
sl@0	786	*/
sl@0	787
sl@0	788	Proc *
sl@0	789	TclFindProc(iPtr, procName)
sl@0	790	Interp iPtr; / Interpreter in which to look. */
sl@0	791	CONST char procName; / Name of desired procedure. */
sl@0	792	{
sl@0	793	Tcl_Command cmd;
sl@0	794	Tcl_Command origCmd;
sl@0	795	Command *cmdPtr;
sl@0	796
sl@0	797	cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
sl@0	798	(Tcl_Namespace ) NULL, /flags*/ 0);
sl@0	799	if (cmd == (Tcl_Command) NULL) {
sl@0	800	return NULL;
sl@0	801	}
sl@0	802	cmdPtr = (Command *) cmd;
sl@0	803
sl@0	804	origCmd = TclGetOriginalCommand(cmd);
sl@0	805	if (origCmd != NULL) {
sl@0	806	cmdPtr = (Command *) origCmd;
sl@0	807	}
sl@0	808	if (cmdPtr->proc != TclProcInterpProc) {
sl@0	809	return NULL;
sl@0	810	}
sl@0	811	return (Proc *) cmdPtr->clientData;
sl@0	812	}
sl@0	813
sl@0	814	/*
sl@0	815	*----------------------------------------------------------------------
sl@0	816	*
sl@0	817	* TclIsProc --
sl@0	818	*
sl@0	819	* Tells whether a command is a Tcl procedure or not.
sl@0	820	*
sl@0	821	* Results:
sl@0	822	* If the given command is actually a Tcl procedure, the
sl@0	823	* return value is the address of the record describing
sl@0	824	* the procedure. Otherwise the return value is 0.
sl@0	825	*
sl@0	826	* Side effects:
sl@0	827	* None.
sl@0	828	*
sl@0	829	*----------------------------------------------------------------------
sl@0	830	*/
sl@0	831
sl@0	832	Proc *
sl@0	833	TclIsProc(cmdPtr)
sl@0	834	Command cmdPtr; / Command to test. */
sl@0	835	{
sl@0	836	Tcl_Command origCmd;
sl@0	837
sl@0	838	origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
sl@0	839	if (origCmd != NULL) {
sl@0	840	cmdPtr = (Command *) origCmd;
sl@0	841	}
sl@0	842	if (cmdPtr->proc == TclProcInterpProc) {
sl@0	843	return (Proc *) cmdPtr->clientData;
sl@0	844	}
sl@0	845	return (Proc *) 0;
sl@0	846	}
sl@0	847
sl@0	848	/*
sl@0	849	*----------------------------------------------------------------------
sl@0	850	*
sl@0	851	* TclProcInterpProc --
sl@0	852	*
sl@0	853	* When a Tcl procedure gets invoked with an argc/argv array of
sl@0	854	* strings, this routine gets invoked to interpret the procedure.
sl@0	855	*
sl@0	856	* Results:
sl@0	857	* A standard Tcl result value, usually TCL_OK.
sl@0	858	*
sl@0	859	* Side effects:
sl@0	860	* Depends on the commands in the procedure.
sl@0	861	*
sl@0	862	*----------------------------------------------------------------------
sl@0	863	*/
sl@0	864
sl@0	865	int
sl@0	866	TclProcInterpProc(clientData, interp, argc, argv)
sl@0	867	ClientData clientData; /* Record describing procedure to be
sl@0	868	* interpreted. */
sl@0	869	Tcl_Interp interp; / Interpreter in which procedure was
sl@0	870	* invoked. */
sl@0	871	int argc; /* Count of number of arguments to this
sl@0	872	* procedure. */
sl@0	873	register CONST char *argv; / Argument values. */
sl@0	874	{
sl@0	875	register Tcl_Obj *objPtr;
sl@0	876	register int i;
sl@0	877	int result;
sl@0	878
sl@0	879	/*
sl@0	880	* This procedure generates an objv array for object arguments that hold
sl@0	881	* the argv strings. It starts out with stack-allocated space but uses
sl@0	882	* dynamically-allocated storage if needed.
sl@0	883	*/
sl@0	884
sl@0	885	#define NUM_ARGS 20
sl@0	886	Tcl_Obj *(objStorage[NUM_ARGS]);
sl@0	887	register Tcl_Obj **objv = objStorage;
sl@0	888
sl@0	889	/*
sl@0	890	* Create the object argument array "objv". Make sure objv is large
sl@0	891	* enough to hold the objc arguments plus 1 extra for the zero
sl@0	892	* end-of-objv word.
sl@0	893	*/
sl@0	894
sl@0	895	if ((argc + 1) > NUM_ARGS) {
sl@0	896	objv = (Tcl_Obj **)
sl@0	897	ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
sl@0	898	}
sl@0	899
sl@0	900	for (i = 0; i < argc; i++) {
sl@0	901	objv[i] = Tcl_NewStringObj(argv[i], -1);
sl@0	902	Tcl_IncrRefCount(objv[i]);
sl@0	903	}
sl@0	904	objv[argc] = 0;
sl@0	905
sl@0	906	/*
sl@0	907	* Use TclObjInterpProc to actually interpret the procedure.
sl@0	908	*/
sl@0	909
sl@0	910	result = TclObjInterpProc(clientData, interp, argc, objv);
sl@0	911
sl@0	912	/*
sl@0	913	* Move the interpreter's object result to the string result,
sl@0	914	* then reset the object result.
sl@0	915	*/
sl@0	916
sl@0	917	Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
sl@0	918	TCL_VOLATILE);
sl@0	919
sl@0	920	/*
sl@0	921	* Decrement the ref counts on the objv elements since we are done
sl@0	922	* with them.
sl@0	923	*/
sl@0	924
sl@0	925	for (i = 0; i < argc; i++) {
sl@0	926	objPtr = objv[i];
sl@0	927	TclDecrRefCount(objPtr);
sl@0	928	}
sl@0	929
sl@0	930	/*
sl@0	931	* Free the objv array if malloc'ed storage was used.
sl@0	932	*/
sl@0	933
sl@0	934	if (objv != objStorage) {
sl@0	935	ckfree((char *) objv);
sl@0	936	}
sl@0	937	return result;
sl@0	938	#undef NUM_ARGS
sl@0	939	}
sl@0	940
sl@0	941	/*
sl@0	942	*----------------------------------------------------------------------
sl@0	943	*
sl@0	944	* TclObjInterpProc --
sl@0	945	*
sl@0	946	* When a Tcl procedure gets invoked during bytecode evaluation, this
sl@0	947	* object-based routine gets invoked to interpret the procedure.
sl@0	948	*
sl@0	949	* Results:
sl@0	950	* A standard Tcl object result value.
sl@0	951	*
sl@0	952	* Side effects:
sl@0	953	* Depends on the commands in the procedure.
sl@0	954	*
sl@0	955	*----------------------------------------------------------------------
sl@0	956	*/
sl@0	957
sl@0	958	int
sl@0	959	TclObjInterpProc(clientData, interp, objc, objv)
sl@0	960	ClientData clientData; /* Record describing procedure to be
sl@0	961	* interpreted. */
sl@0	962	register Tcl_Interp interp; / Interpreter in which procedure was
sl@0	963	* invoked. */
sl@0	964	int objc; /* Count of number of arguments to this
sl@0	965	* procedure. */
sl@0	966	Tcl_Obj CONST objv[]; / Argument value objects. */
sl@0	967	{
sl@0	968	Interp iPtr = (Interp ) interp;
sl@0	969	Proc procPtr = (Proc ) clientData;
sl@0	970	Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
sl@0	971	CallFrame frame;
sl@0	972	register CallFrame *framePtr = &frame;
sl@0	973	register Var *varPtr;
sl@0	974	register CompiledLocal *localPtr;
sl@0	975	char *procName;
sl@0	976	int nameLen, localCt, numArgs, argCt, i, result;
sl@0	977
sl@0	978	/*
sl@0	979	* This procedure generates an array "compiledLocals" that holds the
sl@0	980	* storage for local variables. It starts out with stack-allocated space
sl@0	981	* but uses dynamically-allocated storage if needed.
sl@0	982	*/
sl@0	983
sl@0	984	#define NUM_LOCALS 20
sl@0	985	Var localStorage[NUM_LOCALS];
sl@0	986	Var *compiledLocals = localStorage;
sl@0	987
sl@0	988	/*
sl@0	989	* Get the procedure's name.
sl@0	990	*/
sl@0	991
sl@0	992	procName = Tcl_GetStringFromObj(objv[0], &nameLen);
sl@0	993
sl@0	994	/*
sl@0	995	* If necessary, compile the procedure's body. The compiler will
sl@0	996	* allocate frame slots for the procedure's non-argument local
sl@0	997	* variables. Note that compiling the body might increase
sl@0	998	* procPtr->numCompiledLocals if new local variables are found
sl@0	999	* while compiling.
sl@0	1000	*/
sl@0	1001
sl@0	1002	result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
sl@0	1003	"body of proc", procName, &procPtr);
sl@0	1004
sl@0	1005	if (result != TCL_OK) {
sl@0	1006	return result;
sl@0	1007	}
sl@0	1008
sl@0	1009	/*
sl@0	1010	* Create the "compiledLocals" array. Make sure it is large enough to
sl@0	1011	* hold all the procedure's compiled local variables, including its
sl@0	1012	* formal parameters.
sl@0	1013	*/
sl@0	1014
sl@0	1015	localCt = procPtr->numCompiledLocals;
sl@0	1016	if (localCt > NUM_LOCALS) {
sl@0	1017	compiledLocals = (Var ) ckalloc((unsigned) localCt sizeof(Var));
sl@0	1018	}
sl@0	1019
sl@0	1020	/*
sl@0	1021	* Set up and push a new call frame for the new procedure invocation.
sl@0	1022	* This call frame will execute in the proc's namespace, which might
sl@0	1023	* be different than the current namespace. The proc's namespace is
sl@0	1024	* that of its command, which can change if the command is renamed
sl@0	1025	* from one namespace to another.
sl@0	1026	*/
sl@0	1027
sl@0	1028	result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
sl@0	1029	(Tcl_Namespace ) nsPtr, /isProcCallFrame*/ 1);
sl@0	1030
sl@0	1031	if (result != TCL_OK) {
sl@0	1032	return result;
sl@0	1033	}
sl@0	1034
sl@0	1035	framePtr->objc = objc;
sl@0	1036	framePtr->objv = objv; /* ref counts for args are incremented below */
sl@0	1037
sl@0	1038	/*
sl@0	1039	* Initialize and resolve compiled variable references.
sl@0	1040	*/
sl@0	1041
sl@0	1042	framePtr->procPtr = procPtr;
sl@0	1043	framePtr->numCompiledLocals = localCt;
sl@0	1044	framePtr->compiledLocals = compiledLocals;
sl@0	1045
sl@0	1046	TclInitCompiledLocals(interp, framePtr, nsPtr);
sl@0	1047
sl@0	1048	/*
sl@0	1049	* Match and assign the call's actual parameters to the procedure's
sl@0	1050	* formal arguments. The formal arguments are described by the first
sl@0	1051	* numArgs entries in both the Proc structure's local variable list and
sl@0	1052	* the call frame's local variable array.
sl@0	1053	*/
sl@0	1054
sl@0	1055	numArgs = procPtr->numArgs;
sl@0	1056	varPtr = framePtr->compiledLocals;
sl@0	1057	localPtr = procPtr->firstLocalPtr;
sl@0	1058	argCt = objc;
sl@0	1059	for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) {
sl@0	1060	if (!TclIsVarArgument(localPtr)) {
sl@0	1061	panic("TclObjInterpProc: local variable %s is not argument but should be",
sl@0	1062	localPtr->name);
sl@0	1063	return TCL_ERROR;
sl@0	1064	}
sl@0	1065	if (TclIsVarTemporary(localPtr)) {
sl@0	1066	panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
sl@0	1067	return TCL_ERROR;
sl@0	1068	}
sl@0	1069
sl@0	1070	/*
sl@0	1071	* Handle the special case of the last formal being "args". When
sl@0	1072	* it occurs, assign it a list consisting of all the remaining
sl@0	1073	* actual arguments.
sl@0	1074	*/
sl@0	1075
sl@0	1076	if ((i == numArgs) && ((localPtr->name[0] == 'a')
sl@0	1077	&& (strcmp(localPtr->name, "args") == 0))) {
sl@0	1078	Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
sl@0	1079	varPtr->value.objPtr = listPtr;
sl@0	1080	Tcl_IncrRefCount(listPtr); /* local var is a reference */
sl@0	1081	TclClearVarUndefined(varPtr);
sl@0	1082	argCt = 0;
sl@0	1083	break; /* done processing args */
sl@0	1084	} else if (argCt > 0) {
sl@0	1085	Tcl_Obj *objPtr = objv[i];
sl@0	1086	varPtr->value.objPtr = objPtr;
sl@0	1087	TclClearVarUndefined(varPtr);
sl@0	1088	Tcl_IncrRefCount(objPtr); /* since the local variable now has
sl@0	1089	* another reference to object. */
sl@0	1090	} else if (localPtr->defValuePtr != NULL) {
sl@0	1091	Tcl_Obj *objPtr = localPtr->defValuePtr;
sl@0	1092	varPtr->value.objPtr = objPtr;
sl@0	1093	TclClearVarUndefined(varPtr);
sl@0	1094	Tcl_IncrRefCount(objPtr); /* since the local variable now has
sl@0	1095	* another reference to object. */
sl@0	1096	} else {
sl@0	1097	goto incorrectArgs;
sl@0	1098	}
sl@0	1099	varPtr++;
sl@0	1100	localPtr = localPtr->nextPtr;
sl@0	1101	}
sl@0	1102	if (argCt > 0) {
sl@0	1103	Tcl_Obj *objResult;
sl@0	1104	int len, flags;
sl@0	1105
sl@0	1106	incorrectArgs:
sl@0	1107	/*
sl@0	1108	* Build up equivalent to Tcl_WrongNumArgs message for proc
sl@0	1109	*/
sl@0	1110
sl@0	1111	Tcl_ResetResult(interp);
sl@0	1112	objResult = Tcl_GetObjResult(interp);
sl@0	1113	Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);
sl@0	1114
sl@0	1115	/*
sl@0	1116	* Quote the proc name if it contains spaces (Bug 942757).
sl@0	1117	*/
sl@0	1118
sl@0	1119	len = Tcl_ScanCountedElement(procName, nameLen, &flags);
sl@0	1120	if (len != nameLen) {
sl@0	1121	char *procName1 = ckalloc((unsigned) len);
sl@0	1122	len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
sl@0	1123	Tcl_AppendToObj(objResult, procName1, len);
sl@0	1124	ckfree(procName1);
sl@0	1125	} else {
sl@0	1126	Tcl_AppendToObj(objResult, procName, len);
sl@0	1127	}
sl@0	1128
sl@0	1129	localPtr = procPtr->firstLocalPtr;
sl@0	1130	for (i = 1; i <= numArgs; i++) {
sl@0	1131	if (localPtr->defValuePtr != NULL) {
sl@0	1132	Tcl_AppendStringsToObj(objResult,
sl@0	1133	" ?", localPtr->name, "?", (char *) NULL);
sl@0	1134	} else {
sl@0	1135	Tcl_AppendStringsToObj(objResult,
sl@0	1136	" ", localPtr->name, (char *) NULL);
sl@0	1137	}
sl@0	1138	localPtr = localPtr->nextPtr;
sl@0	1139	}
sl@0	1140	Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL);
sl@0	1141
sl@0	1142	result = TCL_ERROR;
sl@0	1143	goto procDone;
sl@0	1144	}
sl@0	1145
sl@0	1146	/*
sl@0	1147	* Invoke the commands in the procedure's body.
sl@0	1148	*/
sl@0	1149
sl@0	1150	#ifdef TCL_COMPILE_DEBUG
sl@0	1151	if (tclTraceExec >= 1) {
sl@0	1152	fprintf(stdout, "Calling proc ");
sl@0	1153	for (i = 0; i < objc; i++) {
sl@0	1154	TclPrintObject(stdout, objv[i], 15);
sl@0	1155	fprintf(stdout, " ");
sl@0	1156	}
sl@0	1157	fprintf(stdout, "\n");
sl@0	1158	fflush(stdout);
sl@0	1159	}
sl@0	1160	#endif /TCL_COMPILE_DEBUG/
sl@0	1161
sl@0	1162	iPtr->returnCode = TCL_OK;
sl@0	1163	procPtr->refCount++;
sl@0	1164	#ifndef TCL_TIP280
sl@0	1165	result = TclCompEvalObj(interp, procPtr->bodyPtr);
sl@0	1166	#else
sl@0	1167	/* TIP #280: No need to set the invoking context here. The body has
sl@0	1168	* already been compiled, so the part of CompEvalObj using it is bypassed.
sl@0	1169	*/
sl@0	1170
sl@0	1171	result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0);
sl@0	1172	#endif
sl@0	1173	procPtr->refCount--;
sl@0	1174	if (procPtr->refCount <= 0) {
sl@0	1175	TclProcCleanupProc(procPtr);
sl@0	1176	}
sl@0	1177
sl@0	1178	if (result != TCL_OK) {
sl@0	1179	result = ProcessProcResultCode(interp, procName, nameLen, result);
sl@0	1180	}
sl@0	1181
sl@0	1182	/*
sl@0	1183	* Pop and free the call frame for this procedure invocation, then
sl@0	1184	* free the compiledLocals array if malloc'ed storage was used.
sl@0	1185	*/
sl@0	1186
sl@0	1187	procDone:
sl@0	1188	Tcl_PopCallFrame(interp);
sl@0	1189	if (compiledLocals != localStorage) {
sl@0	1190	ckfree((char *) compiledLocals);
sl@0	1191	}
sl@0	1192	return result;
sl@0	1193	#undef NUM_LOCALS
sl@0	1194	}
sl@0	1195
sl@0	1196	/*
sl@0	1197	*----------------------------------------------------------------------
sl@0	1198	*
sl@0	1199	* TclProcCompileProc --
sl@0	1200	*
sl@0	1201	* Called just before a procedure is executed to compile the
sl@0	1202	* body to byte codes. If the type of the body is not
sl@0	1203	* "byte code" or if the compile conditions have changed
sl@0	1204	* (namespace context, epoch counters, etc.) then the body
sl@0	1205	* is recompiled. Otherwise, this procedure does nothing.
sl@0	1206	*
sl@0	1207	* Results:
sl@0	1208	* None.
sl@0	1209	*
sl@0	1210	* Side effects:
sl@0	1211	* May change the internal representation of the body object
sl@0	1212	* to compiled code.
sl@0	1213	*
sl@0	1214	*----------------------------------------------------------------------
sl@0	1215	*/
sl@0	1216
sl@0	1217	int
sl@0	1218	TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
sl@0	1219	Tcl_Interp interp; / Interpreter containing procedure. */
sl@0	1220	Proc procPtr; / Data associated with procedure. */
sl@0	1221	Tcl_Obj bodyPtr; / Body of proc. (Usually procPtr->bodyPtr,
sl@0	1222	* but could be any code fragment compiled
sl@0	1223	* in the context of this procedure.) */
sl@0	1224	Namespace nsPtr; / Namespace containing procedure. */
sl@0	1225	CONST char description; / string describing this body of code. */
sl@0	1226	CONST char procName; / Name of this procedure. */
sl@0	1227	{
sl@0	1228	return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr,
sl@0	1229	description, procName, NULL);
sl@0	1230	}
sl@0	1231
sl@0	1232	static int
sl@0	1233	ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
sl@0	1234	procName, procPtrPtr)
sl@0	1235	Tcl_Interp interp; / Interpreter containing procedure. */
sl@0	1236	Proc procPtr; / Data associated with procedure. */
sl@0	1237	Tcl_Obj bodyPtr; / Body of proc. (Usually procPtr->bodyPtr,
sl@0	1238	* but could be any code fragment compiled
sl@0	1239	* in the context of this procedure.) */
sl@0	1240	Namespace nsPtr; / Namespace containing procedure. */
sl@0	1241	CONST char description; / string describing this body of code. */
sl@0	1242	CONST char procName; / Name of this procedure. */
sl@0	1243	Proc *procPtrPtr; / points to storage where a replacement
sl@0	1244	* (Proc *) value may be written, when
sl@0	1245	* appropriate */
sl@0	1246	{
sl@0	1247	Interp iPtr = (Interp)interp;
sl@0	1248	int i, result;
sl@0	1249	Tcl_CallFrame frame;
sl@0	1250	Proc *saveProcPtr;
sl@0	1251	ByteCode codePtr = (ByteCode ) bodyPtr->internalRep.otherValuePtr;
sl@0	1252	CompiledLocal *localPtr;
sl@0	1253
sl@0	1254	/*
sl@0	1255	* If necessary, compile the procedure's body. The compiler will
sl@0	1256	* allocate frame slots for the procedure's non-argument local
sl@0	1257	* variables. If the ByteCode already exists, make sure it hasn't been
sl@0	1258	* invalidated by someone redefining a core command (this might make the
sl@0	1259	* compiled code wrong). Also, if the code was compiled in/for a
sl@0	1260	* different interpreter, we recompile it. Note that compiling the body
sl@0	1261	* might increase procPtr->numCompiledLocals if new local variables are
sl@0	1262	* found while compiling.
sl@0	1263	*
sl@0	1264	* Precompiled procedure bodies, however, are immutable and therefore
sl@0	1265	* they are not recompiled, even if things have changed.
sl@0	1266	*/
sl@0	1267
sl@0	1268	if (bodyPtr->typePtr == &tclByteCodeType) {
sl@0	1269	if (((Interp ) codePtr->interpHandle != iPtr)
sl@0	1270	\|\| (codePtr->compileEpoch != iPtr->compileEpoch)
sl@0	1271	\|\| (codePtr->nsPtr != nsPtr)) {
sl@0	1272	if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
sl@0	1273	if ((Interp ) codePtr->interpHandle != iPtr) {
sl@0	1274	Tcl_AppendResult(interp,
sl@0	1275	"a precompiled script jumped interps", NULL);
sl@0	1276	return TCL_ERROR;
sl@0	1277	}
sl@0	1278	codePtr->compileEpoch = iPtr->compileEpoch;
sl@0	1279	codePtr->nsPtr = nsPtr;
sl@0	1280	} else {
sl@0	1281	(*tclByteCodeType.freeIntRepProc)(bodyPtr);
sl@0	1282	bodyPtr->typePtr = (Tcl_ObjType *) NULL;
sl@0	1283	}
sl@0	1284	}
sl@0	1285	}
sl@0	1286	if (bodyPtr->typePtr != &tclByteCodeType) {
sl@0	1287	int numChars;
sl@0	1288	char *ellipsis;
sl@0	1289
sl@0	1290	#ifdef TCL_COMPILE_DEBUG
sl@0	1291	if (tclTraceCompile >= 1) {
sl@0	1292	/*
sl@0	1293	* Display a line summarizing the top level command we
sl@0	1294	* are about to compile.
sl@0	1295	*/
sl@0	1296
sl@0	1297	numChars = strlen(procName);
sl@0	1298	ellipsis = "";
sl@0	1299	if (numChars > 50) {
sl@0	1300	numChars = 50;
sl@0	1301	ellipsis = "...";
sl@0	1302	}
sl@0	1303	fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
sl@0	1304	description, numChars, procName, ellipsis);
sl@0	1305	}
sl@0	1306	#endif
sl@0	1307
sl@0	1308	/*
sl@0	1309	* Plug the current procPtr into the interpreter and coerce
sl@0	1310	* the code body to byte codes. The interpreter needs to
sl@0	1311	* know which proc it's compiling so that it can access its
sl@0	1312	* list of compiled locals.
sl@0	1313	*
sl@0	1314	* TRICKY NOTE: Be careful to push a call frame with the
sl@0	1315	* proper namespace context, so that the byte codes are
sl@0	1316	* compiled in the appropriate class context.
sl@0	1317	*/
sl@0	1318
sl@0	1319	saveProcPtr = iPtr->compiledProcPtr;
sl@0	1320
sl@0	1321	if (procPtrPtr != NULL && procPtr->refCount > 1) {
sl@0	1322	Tcl_Command token;
sl@0	1323	Tcl_CmdInfo info;
sl@0	1324	Proc new = (Proc ) ckalloc(sizeof(Proc));
sl@0	1325
sl@0	1326	new->iPtr = procPtr->iPtr;
sl@0	1327	new->refCount = 1;
sl@0	1328	new->cmdPtr = procPtr->cmdPtr;
sl@0	1329	token = (Tcl_Command) new->cmdPtr;
sl@0	1330	new->bodyPtr = Tcl_DuplicateObj(bodyPtr);
sl@0	1331	bodyPtr = new->bodyPtr;
sl@0	1332	Tcl_IncrRefCount(bodyPtr);
sl@0	1333	new->numArgs = procPtr->numArgs;
sl@0	1334
sl@0	1335	new->numCompiledLocals = new->numArgs;
sl@0	1336	new->firstLocalPtr = NULL;
sl@0	1337	new->lastLocalPtr = NULL;
sl@0	1338	localPtr = procPtr->firstLocalPtr;
sl@0	1339	for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) {
sl@0	1340	CompiledLocal copy = (CompiledLocal ) ckalloc((unsigned)
sl@0	1341	(sizeof(CompiledLocal) -sizeof(localPtr->name)
sl@0	1342	+ localPtr->nameLength + 1));
sl@0	1343	if (new->firstLocalPtr == NULL) {
sl@0	1344	new->firstLocalPtr = new->lastLocalPtr = copy;
sl@0	1345	} else {
sl@0	1346	new->lastLocalPtr->nextPtr = copy;
sl@0	1347	new->lastLocalPtr = copy;
sl@0	1348	}
sl@0	1349	copy->nextPtr = NULL;
sl@0	1350	copy->nameLength = localPtr->nameLength;
sl@0	1351	copy->frameIndex = localPtr->frameIndex;
sl@0	1352	copy->flags = localPtr->flags;
sl@0	1353	copy->defValuePtr = localPtr->defValuePtr;
sl@0	1354	if (copy->defValuePtr) {
sl@0	1355	Tcl_IncrRefCount(copy->defValuePtr);
sl@0	1356	}
sl@0	1357	copy->resolveInfo = localPtr->resolveInfo;
sl@0	1358	strcpy(copy->name, localPtr->name);
sl@0	1359	}
sl@0	1360
sl@0	1361
sl@0	1362	/* Reset the ClientData */
sl@0	1363	Tcl_GetCommandInfoFromToken(token, &info);
sl@0	1364	if (info.objClientData == (ClientData) procPtr) {
sl@0	1365	info.objClientData = (ClientData) new;
sl@0	1366	}
sl@0	1367	if (info.clientData == (ClientData) procPtr) {
sl@0	1368	info.clientData = (ClientData) new;
sl@0	1369	}
sl@0	1370	if (info.deleteData == (ClientData) procPtr) {
sl@0	1371	info.deleteData = (ClientData) new;
sl@0	1372	}
sl@0	1373	Tcl_SetCommandInfoFromToken(token, &info);
sl@0	1374
sl@0	1375	procPtr->refCount--;
sl@0	1376	*procPtrPtr = procPtr = new;
sl@0	1377	}
sl@0	1378	iPtr->compiledProcPtr = procPtr;
sl@0	1379
sl@0	1380	result = Tcl_PushCallFrame(interp, &frame,
sl@0	1381	(Tcl_Namespace)nsPtr, / isProcCallFrame */ 0);
sl@0	1382
sl@0	1383	if (result == TCL_OK) {
sl@0	1384	#ifdef TCL_TIP280
sl@0	1385	/* TIP #280. We get the invoking context from the cmdFrame
sl@0	1386	* which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
sl@0	1387	*/
sl@0	1388
sl@0	1389	Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
sl@0	1390
sl@0	1391	/* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
sl@0	1392	*/
sl@0	1393	iPtr->invokeWord = 0;
sl@0	1394	iPtr->invokeCmdFramePtr = (hePtr
sl@0	1395	? (CmdFrame*) Tcl_GetHashValue (hePtr)
sl@0	1396	: NULL);
sl@0	1397	#endif
sl@0	1398	result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
sl@0	1399	#ifdef TCL_TIP280
sl@0	1400	iPtr->invokeCmdFramePtr = NULL;
sl@0	1401	#endif
sl@0	1402	Tcl_PopCallFrame(interp);
sl@0	1403	}
sl@0	1404
sl@0	1405	iPtr->compiledProcPtr = saveProcPtr;
sl@0	1406
sl@0	1407	if (result != TCL_OK) {
sl@0	1408	if (result == TCL_ERROR) {
sl@0	1409	char buf[100 + TCL_INTEGER_SPACE];
sl@0	1410
sl@0	1411	numChars = strlen(procName);
sl@0	1412	ellipsis = "";
sl@0	1413	if (numChars > 50) {
sl@0	1414	numChars = 50;
sl@0	1415	ellipsis = "...";
sl@0	1416	}
sl@0	1417	while ( (procName[numChars] & 0xC0) == 0x80 ) {
sl@0	1418	/*
sl@0	1419	* Back up truncation point so that we don't truncate
sl@0	1420	* in the middle of a multi-byte character (in UTF-8)
sl@0	1421	*/
sl@0	1422	numChars--;
sl@0	1423	ellipsis = "...";
sl@0	1424	}
sl@0	1425	sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
sl@0	1426	description, numChars, procName, ellipsis,
sl@0	1427	interp->errorLine);
sl@0	1428	Tcl_AddObjErrorInfo(interp, buf, -1);
sl@0	1429	}
sl@0	1430	return result;
sl@0	1431	}
sl@0	1432	} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
sl@0	1433
sl@0	1434	/*
sl@0	1435	* The resolver epoch has changed, but we only need to invalidate
sl@0	1436	* the resolver cache.
sl@0	1437	*/
sl@0	1438
sl@0	1439	for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
sl@0	1440	localPtr = localPtr->nextPtr) {
sl@0	1441	localPtr->flags &= ~(VAR_RESOLVED);
sl@0	1442	if (localPtr->resolveInfo) {
sl@0	1443	if (localPtr->resolveInfo->deleteProc) {
sl@0	1444	localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
sl@0	1445	} else {
sl@0	1446	ckfree((char*)localPtr->resolveInfo);
sl@0	1447	}
sl@0	1448	localPtr->resolveInfo = NULL;
sl@0	1449	}
sl@0	1450	}
sl@0	1451	}
sl@0	1452	return TCL_OK;
sl@0	1453	}
sl@0	1454
sl@0	1455	/*
sl@0	1456	*----------------------------------------------------------------------
sl@0	1457	*
sl@0	1458	* ProcessProcResultCode --
sl@0	1459	*
sl@0	1460	* Procedure called by TclObjInterpProc to process a return code other
sl@0	1461	* than TCL_OK returned by a Tcl procedure.
sl@0	1462	*
sl@0	1463	* Results:
sl@0	1464	* Depending on the argument return code, the result returned is
sl@0	1465	* another return code and the interpreter's result is set to a value
sl@0	1466	* to supplement that return code.
sl@0	1467	*
sl@0	1468	* Side effects:
sl@0	1469	* If the result returned is TCL_ERROR, traceback information about
sl@0	1470	* the procedure just executed is appended to the interpreter's
sl@0	1471	* "errorInfo" variable.
sl@0	1472	*
sl@0	1473	*----------------------------------------------------------------------
sl@0	1474	*/
sl@0	1475
sl@0	1476	static int
sl@0	1477	ProcessProcResultCode(interp, procName, nameLen, returnCode)
sl@0	1478	Tcl_Interp interp; / The interpreter in which the procedure
sl@0	1479	* was called and returned returnCode. */
sl@0	1480	char procName; / Name of the procedure. Used for error
sl@0	1481	* messages and trace information. */
sl@0	1482	int nameLen; /* Number of bytes in procedure's name. */
sl@0	1483	int returnCode; /* The unexpected result code. */
sl@0	1484	{
sl@0	1485	Interp iPtr = (Interp ) interp;
sl@0	1486	char msg[100 + TCL_INTEGER_SPACE];
sl@0	1487	char *ellipsis = "";
sl@0	1488
sl@0	1489	if (returnCode == TCL_OK) {
sl@0	1490	return TCL_OK;
sl@0	1491	}
sl@0	1492	if ((returnCode > TCL_CONTINUE) \|\| (returnCode < TCL_OK)) {
sl@0	1493	return returnCode;
sl@0	1494	}
sl@0	1495	if (returnCode == TCL_RETURN) {
sl@0	1496	return TclUpdateReturnInfo(iPtr);
sl@0	1497	}
sl@0	1498	if (returnCode != TCL_ERROR) {
sl@0	1499	Tcl_ResetResult(interp);
sl@0	1500	Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK)
sl@0	1501	? "invoked \"break\" outside of a loop"
sl@0	1502	: "invoked \"continue\" outside of a loop"), -1);
sl@0	1503	}
sl@0	1504	if (nameLen > 60) {
sl@0	1505	nameLen = 60;
sl@0	1506	ellipsis = "...";
sl@0	1507	}
sl@0	1508	while ( (procName[nameLen] & 0xC0) == 0x80 ) {
sl@0	1509	/*
sl@0	1510	* Back up truncation point so that we don't truncate in the
sl@0	1511	* middle of a multi-byte character (in UTF-8)
sl@0	1512	*/
sl@0	1513	nameLen--;
sl@0	1514	ellipsis = "...";
sl@0	1515	}
sl@0	1516	sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
sl@0	1517	ellipsis, iPtr->errorLine);
sl@0	1518	Tcl_AddObjErrorInfo(interp, msg, -1);
sl@0	1519	return TCL_ERROR;
sl@0	1520	}
sl@0	1521
sl@0	1522	/*
sl@0	1523	*----------------------------------------------------------------------
sl@0	1524	*
sl@0	1525	* TclProcDeleteProc --
sl@0	1526	*
sl@0	1527	* This procedure is invoked just before a command procedure is
sl@0	1528	* removed from an interpreter. Its job is to release all the
sl@0	1529	* resources allocated to the procedure.
sl@0	1530	*
sl@0	1531	* Results:
sl@0	1532	* None.
sl@0	1533	*
sl@0	1534	* Side effects:
sl@0	1535	* Memory gets freed, unless the procedure is actively being
sl@0	1536	* executed. In this case the cleanup is delayed until the
sl@0	1537	* last call to the current procedure completes.
sl@0	1538	*
sl@0	1539	*----------------------------------------------------------------------
sl@0	1540	*/
sl@0	1541
sl@0	1542	void
sl@0	1543	TclProcDeleteProc(clientData)
sl@0	1544	ClientData clientData; /* Procedure to be deleted. */
sl@0	1545	{
sl@0	1546	Proc procPtr = (Proc ) clientData;
sl@0	1547
sl@0	1548	procPtr->refCount--;
sl@0	1549	if (procPtr->refCount <= 0) {
sl@0	1550	TclProcCleanupProc(procPtr);
sl@0	1551	}
sl@0	1552	}
sl@0	1553
sl@0	1554	/*
sl@0	1555	*----------------------------------------------------------------------
sl@0	1556	*
sl@0	1557	* TclProcCleanupProc --
sl@0	1558	*
sl@0	1559	* This procedure does all the real work of freeing up a Proc
sl@0	1560	* structure. It's called only when the structure's reference
sl@0	1561	* count becomes zero.
sl@0	1562	*
sl@0	1563	* Results:
sl@0	1564	* None.
sl@0	1565	*
sl@0	1566	* Side effects:
sl@0	1567	* Memory gets freed.
sl@0	1568	*
sl@0	1569	*----------------------------------------------------------------------
sl@0	1570	*/
sl@0	1571
sl@0	1572	void
sl@0	1573	TclProcCleanupProc(procPtr)
sl@0	1574	register Proc procPtr; / Procedure to be deleted. */
sl@0	1575	{
sl@0	1576	register CompiledLocal *localPtr;
sl@0	1577	Tcl_Obj *bodyPtr = procPtr->bodyPtr;
sl@0	1578	Tcl_Obj *defPtr;
sl@0	1579	Tcl_ResolvedVarInfo *resVarInfo;
sl@0	1580	#ifdef TCL_TIP280
sl@0	1581	Tcl_HashEntry* hePtr = NULL;
sl@0	1582	CmdFrame* cfPtr = NULL;
sl@0	1583	Interp* iPtr = procPtr->iPtr;
sl@0	1584	#endif
sl@0	1585
sl@0	1586	if (bodyPtr != NULL) {
sl@0	1587	Tcl_DecrRefCount(bodyPtr);
sl@0	1588	}
sl@0	1589	for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
sl@0	1590	CompiledLocal *nextPtr = localPtr->nextPtr;
sl@0	1591
sl@0	1592	resVarInfo = localPtr->resolveInfo;
sl@0	1593	if (resVarInfo) {
sl@0	1594	if (resVarInfo->deleteProc) {
sl@0	1595	(*resVarInfo->deleteProc)(resVarInfo);
sl@0	1596	} else {
sl@0	1597	ckfree((char *) resVarInfo);
sl@0	1598	}
sl@0	1599	}
sl@0	1600
sl@0	1601	if (localPtr->defValuePtr != NULL) {
sl@0	1602	defPtr = localPtr->defValuePtr;
sl@0	1603	Tcl_DecrRefCount(defPtr);
sl@0	1604	}
sl@0	1605	ckfree((char *) localPtr);
sl@0	1606	localPtr = nextPtr;
sl@0	1607	}
sl@0	1608	ckfree((char *) procPtr);
sl@0	1609
sl@0	1610	#ifdef TCL_TIP280
sl@0	1611	/* TIP #280. Release the location data associated with this Proc
sl@0	1612	* structure, if any. The interpreter may not exist (For example for
sl@0	1613	* procbody structurues created by tbcload.
sl@0	1614	*/
sl@0	1615
sl@0	1616	if (!iPtr) return;
sl@0	1617
sl@0	1618	hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
sl@0	1619	if (!hePtr) return;
sl@0	1620
sl@0	1621	cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr);
sl@0	1622
sl@0	1623	if (cfPtr->type == TCL_LOCATION_SOURCE) {
sl@0	1624	Tcl_DecrRefCount (cfPtr->data.eval.path);
sl@0	1625	cfPtr->data.eval.path = NULL;
sl@0	1626	}
sl@0	1627	ckfree ((char*) cfPtr->line); cfPtr->line = NULL;
sl@0	1628	ckfree ((char*) cfPtr);
sl@0	1629	Tcl_DeleteHashEntry (hePtr);
sl@0	1630	#endif
sl@0	1631	}
sl@0	1632
sl@0	1633	/*
sl@0	1634	*----------------------------------------------------------------------
sl@0	1635	*
sl@0	1636	* TclUpdateReturnInfo --
sl@0	1637	*
sl@0	1638	* This procedure is called when procedures return, and at other
sl@0	1639	* points where the TCL_RETURN code is used. It examines fields
sl@0	1640	* such as iPtr->returnCode and iPtr->errorCode and modifies
sl@0	1641	* the real return status accordingly.
sl@0	1642	*
sl@0	1643	* Results:
sl@0	1644	* The return value is the true completion code to use for
sl@0	1645	* the procedure, instead of TCL_RETURN.
sl@0	1646	*
sl@0	1647	* Side effects:
sl@0	1648	* The errorInfo and errorCode variables may get modified.
sl@0	1649	*
sl@0	1650	*----------------------------------------------------------------------
sl@0	1651	*/
sl@0	1652
sl@0	1653	int
sl@0	1654	TclUpdateReturnInfo(iPtr)
sl@0	1655	Interp iPtr; / Interpreter for which TCL_RETURN
sl@0	1656	* exception is being processed. */
sl@0	1657	{
sl@0	1658	int code;
sl@0	1659	char *errorCode;
sl@0	1660	Tcl_Obj *objPtr;
sl@0	1661
sl@0	1662	code = iPtr->returnCode;
sl@0	1663	iPtr->returnCode = TCL_OK;
sl@0	1664	if (code == TCL_ERROR) {
sl@0	1665	errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
sl@0	1666	objPtr = Tcl_NewStringObj(errorCode, -1);
sl@0	1667	Tcl_IncrRefCount(objPtr);
sl@0	1668	Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
sl@0	1669	NULL, objPtr, TCL_GLOBAL_ONLY);
sl@0	1670	Tcl_DecrRefCount(objPtr);
sl@0	1671	iPtr->flags \|= ERROR_CODE_SET;
sl@0	1672	if (iPtr->errorInfo != NULL) {
sl@0	1673	objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1);
sl@0	1674	Tcl_IncrRefCount(objPtr);
sl@0	1675	Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
sl@0	1676	NULL, objPtr, TCL_GLOBAL_ONLY);
sl@0	1677	Tcl_DecrRefCount(objPtr);
sl@0	1678	iPtr->flags \|= ERR_IN_PROGRESS;
sl@0	1679	}
sl@0	1680	}
sl@0	1681	return code;
sl@0	1682	}
sl@0	1683
sl@0	1684	/*
sl@0	1685	*----------------------------------------------------------------------
sl@0	1686	*
sl@0	1687	* TclGetInterpProc --
sl@0	1688	*
sl@0	1689	* Returns a pointer to the TclProcInterpProc procedure; this is different
sl@0	1690	* from the value obtained from the TclProcInterpProc reference on systems
sl@0	1691	* like Windows where import and export versions of a procedure exported
sl@0	1692	* by a DLL exist.
sl@0	1693	*
sl@0	1694	* Results:
sl@0	1695	* Returns the internal address of the TclProcInterpProc procedure.
sl@0	1696	*
sl@0	1697	* Side effects:
sl@0	1698	* None.
sl@0	1699	*
sl@0	1700	*----------------------------------------------------------------------
sl@0	1701	*/
sl@0	1702
sl@0	1703	TclCmdProcType
sl@0	1704	TclGetInterpProc()
sl@0	1705	{
sl@0	1706	return (TclCmdProcType) TclProcInterpProc;
sl@0	1707	}
sl@0	1708
sl@0	1709	/*
sl@0	1710	*----------------------------------------------------------------------
sl@0	1711	*
sl@0	1712	* TclGetObjInterpProc --
sl@0	1713	*
sl@0	1714	* Returns a pointer to the TclObjInterpProc procedure; this is different
sl@0	1715	* from the value obtained from the TclObjInterpProc reference on systems
sl@0	1716	* like Windows where import and export versions of a procedure exported
sl@0	1717	* by a DLL exist.
sl@0	1718	*
sl@0	1719	* Results:
sl@0	1720	* Returns the internal address of the TclObjInterpProc procedure.
sl@0	1721	*
sl@0	1722	* Side effects:
sl@0	1723	* None.
sl@0	1724	*
sl@0	1725	*----------------------------------------------------------------------
sl@0	1726	*/
sl@0	1727
sl@0	1728	TclObjCmdProcType
sl@0	1729	TclGetObjInterpProc()
sl@0	1730	{
sl@0	1731	return (TclObjCmdProcType) TclObjInterpProc;
sl@0	1732	}
sl@0	1733
sl@0	1734	/*
sl@0	1735	*----------------------------------------------------------------------
sl@0	1736	*
sl@0	1737	* TclNewProcBodyObj --
sl@0	1738	*
sl@0	1739	* Creates a new object, of type "procbody", whose internal
sl@0	1740	* representation is the given Proc struct.
sl@0	1741	* The newly created object's reference count is 0.
sl@0	1742	*
sl@0	1743	* Results:
sl@0	1744	* Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
sl@0	1745	*
sl@0	1746	* Side effects:
sl@0	1747	* The reference count in the ByteCode attached to the Proc is bumped up
sl@0	1748	* by one, since the internal rep stores a pointer to it.
sl@0	1749	*
sl@0	1750	*----------------------------------------------------------------------
sl@0	1751	*/
sl@0	1752
sl@0	1753	Tcl_Obj *
sl@0	1754	TclNewProcBodyObj(procPtr)
sl@0	1755	Proc procPtr; / the Proc struct to store as the internal
sl@0	1756	* representation. */
sl@0	1757	{
sl@0	1758	Tcl_Obj *objPtr;
sl@0	1759
sl@0	1760	if (!procPtr) {
sl@0	1761	return (Tcl_Obj *) NULL;
sl@0	1762	}
sl@0	1763
sl@0	1764	objPtr = Tcl_NewStringObj("", 0);
sl@0	1765
sl@0	1766	if (objPtr) {
sl@0	1767	objPtr->typePtr = &tclProcBodyType;
sl@0	1768	objPtr->internalRep.otherValuePtr = (VOID *) procPtr;
sl@0	1769
sl@0	1770	procPtr->refCount++;
sl@0	1771	}
sl@0	1772
sl@0	1773	return objPtr;
sl@0	1774	}
sl@0	1775
sl@0	1776	/*
sl@0	1777	*----------------------------------------------------------------------
sl@0	1778	*
sl@0	1779	* ProcBodyDup --
sl@0	1780	*
sl@0	1781	* Tcl_ObjType's Dup function for the proc body object.
sl@0	1782	* Bumps the reference count on the Proc stored in the internal
sl@0	1783	* representation.
sl@0	1784	*
sl@0	1785	* Results:
sl@0	1786	* None.
sl@0	1787	*
sl@0	1788	* Side effects:
sl@0	1789	* Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
sl@0	1790	*
sl@0	1791	*----------------------------------------------------------------------
sl@0	1792	*/
sl@0	1793
sl@0	1794	static void ProcBodyDup(srcPtr, dupPtr)
sl@0	1795	Tcl_Obj srcPtr; / object to copy */
sl@0	1796	Tcl_Obj dupPtr; / target object for the duplication */
sl@0	1797	{
sl@0	1798	Proc procPtr = (Proc ) srcPtr->internalRep.otherValuePtr;
sl@0	1799
sl@0	1800	dupPtr->typePtr = &tclProcBodyType;
sl@0	1801	dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
sl@0	1802	procPtr->refCount++;
sl@0	1803	}
sl@0	1804
sl@0	1805	/*
sl@0	1806	*----------------------------------------------------------------------
sl@0	1807	*
sl@0	1808	* ProcBodyFree --
sl@0	1809	*
sl@0	1810	* Tcl_ObjType's Free function for the proc body object.
sl@0	1811	* The reference count on its Proc struct is decreased by 1; if the count
sl@0	1812	* reaches 0, the proc is freed.
sl@0	1813	*
sl@0	1814	* Results:
sl@0	1815	* None.
sl@0	1816	*
sl@0	1817	* Side effects:
sl@0	1818	* If the reference count on the Proc struct reaches 0, the struct is freed.
sl@0	1819	*
sl@0	1820	*----------------------------------------------------------------------
sl@0	1821	*/
sl@0	1822
sl@0	1823	static void
sl@0	1824	ProcBodyFree(objPtr)
sl@0	1825	Tcl_Obj objPtr; / the object to clean up */
sl@0	1826	{
sl@0	1827	Proc procPtr = (Proc ) objPtr->internalRep.otherValuePtr;
sl@0	1828	procPtr->refCount--;
sl@0	1829	if (procPtr->refCount <= 0) {
sl@0	1830	TclProcCleanupProc(procPtr);
sl@0	1831	}
sl@0	1832	}
sl@0	1833
sl@0	1834	/*
sl@0	1835	*----------------------------------------------------------------------
sl@0	1836	*
sl@0	1837	* ProcBodySetFromAny --
sl@0	1838	*
sl@0	1839	* Tcl_ObjType's SetFromAny function for the proc body object.
sl@0	1840	* Calls panic.
sl@0	1841	*
sl@0	1842	* Results:
sl@0	1843	* Theoretically returns a TCL result code.
sl@0	1844	*
sl@0	1845	* Side effects:
sl@0	1846	* Calls panic, since we can't set the value of the object from a string
sl@0	1847	* representation (or any other internal ones).
sl@0	1848	*
sl@0	1849	*----------------------------------------------------------------------
sl@0	1850	*/
sl@0	1851
sl@0	1852	static int
sl@0	1853	ProcBodySetFromAny(interp, objPtr)
sl@0	1854	Tcl_Interp interp; / current interpreter */
sl@0	1855	Tcl_Obj objPtr; / object pointer */
sl@0	1856	{
sl@0	1857	panic("called ProcBodySetFromAny");
sl@0	1858
sl@0	1859	/*
sl@0	1860	* this to keep compilers happy.
sl@0	1861	*/
sl@0	1862
sl@0	1863	return TCL_OK;
sl@0	1864	}
sl@0	1865
sl@0	1866	/*
sl@0	1867	*----------------------------------------------------------------------
sl@0	1868	*
sl@0	1869	* ProcBodyUpdateString --
sl@0	1870	*
sl@0	1871	* Tcl_ObjType's UpdateString function for the proc body object.
sl@0	1872	* Calls panic.
sl@0	1873	*
sl@0	1874	* Results:
sl@0	1875	* None.
sl@0	1876	*
sl@0	1877	* Side effects:
sl@0	1878	* Calls panic, since we this type has no string representation.
sl@0	1879	*
sl@0	1880	*----------------------------------------------------------------------
sl@0	1881	*/
sl@0	1882
sl@0	1883	static void
sl@0	1884	ProcBodyUpdateString(objPtr)
sl@0	1885	Tcl_Obj objPtr; / the object to update */
sl@0	1886	{
sl@0	1887	panic("called ProcBodyUpdateString");
sl@0	1888	}
sl@0	1889
sl@0	1890
sl@0	1891	/*
sl@0	1892	*----------------------------------------------------------------------
sl@0	1893	*
sl@0	1894	* TclCompileNoOp --
sl@0	1895	*
sl@0	1896	* Procedure called to compile noOp's
sl@0	1897	*
sl@0	1898	* Results:
sl@0	1899	* The return value is TCL_OK, indicating successful compilation.
sl@0	1900	*
sl@0	1901	* Side effects:
sl@0	1902	* Instructions are added to envPtr to execute a noOp at runtime.
sl@0	1903	*
sl@0	1904	*----------------------------------------------------------------------
sl@0	1905	*/
sl@0	1906
sl@0	1907	static int
sl@0	1908	TclCompileNoOp(interp, parsePtr, envPtr)
sl@0	1909	Tcl_Interp interp; / Used for error reporting. */
sl@0	1910	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	1911	* command created by Tcl_ParseCommand. */
sl@0	1912	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	1913	{
sl@0	1914	Tcl_Token *tokenPtr;
sl@0	1915	int i, code;
sl@0	1916	int savedStackDepth = envPtr->currStackDepth;
sl@0	1917
sl@0	1918	tokenPtr = parsePtr->tokenPtr;
sl@0	1919	for(i = 1; i < parsePtr->numWords; i++) {
sl@0	1920	tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
sl@0	1921	envPtr->currStackDepth = savedStackDepth;
sl@0	1922
sl@0	1923	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0	1924	code = TclCompileTokens(interp, tokenPtr+1,
sl@0	1925	tokenPtr->numComponents, envPtr);
sl@0	1926	if (code != TCL_OK) {
sl@0	1927	return code;
sl@0	1928	}
sl@0	1929	TclEmitOpcode(INST_POP, envPtr);
sl@0	1930	}
sl@0	1931	}
sl@0	1932	envPtr->currStackDepth = savedStackDepth;
sl@0	1933	TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /onHeap/ 0), envPtr);
sl@0	1934	return TCL_OK;
sl@0	1935	}
sl@0	1936
sl@0	1937	/*
sl@0	1938	* Local Variables:
sl@0	1939	* mode: c
sl@0	1940	* c-basic-offset: 4
sl@0	1941	* fill-column: 78
sl@0	1942	* End:
sl@0	1943	*/
sl@0	1944

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--