Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompCmds.c@bde4ae8d615e (annotated)

sl@0	1	/*
sl@0	2	* tclCompCmds.c --
sl@0	3	*
sl@0	4	* This file contains compilation procedures that compile various
sl@0	5	* Tcl commands into a sequence of instructions ("bytecodes").
sl@0	6	*
sl@0	7	* Copyright (c) 1997-1998 Sun Microsystems, Inc.
sl@0	8	* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
sl@0	9	* Copyright (c) 2002 ActiveState Corporation.
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: tclCompCmds.c,v 1.39.2.6 2007/03/01 16:06:19 dkf 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 procedures defined later in this file:
sl@0	22	*/
sl@0	23
sl@0	24	static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
sl@0	25	static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
sl@0	26	#ifndef TCL_TIP280
sl@0	27	static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	28	Tcl_Token varTokenPtr, CompileEnv envPtr, int flags,
sl@0	29	int localIndexPtr, int simpleVarNamePtr, int *isScalarPtr));
sl@0	30	#else
sl@0	31	static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
sl@0	32	Tcl_Token varTokenPtr, CompileEnv envPtr, int flags,
sl@0	33	int localIndexPtr, int simpleVarNamePtr, int *isScalarPtr,
sl@0	34	int line));
sl@0	35	#endif
sl@0	36
sl@0	37	/*
sl@0	38	* Flags bits used by TclPushVarName.
sl@0	39	*/
sl@0	40
sl@0	41	#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
sl@0	42	#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
sl@0	43
sl@0	44	/*
sl@0	45	* The structures below define the AuxData types defined in this file.
sl@0	46	*/
sl@0	47
sl@0	48	AuxDataType tclForeachInfoType = {
sl@0	49	"ForeachInfo", /* name */
sl@0	50	DupForeachInfo, /* dupProc */
sl@0	51	FreeForeachInfo /* freeProc */
sl@0	52	};
sl@0	53
sl@0	54	/*
sl@0	55	*----------------------------------------------------------------------
sl@0	56	*
sl@0	57	* TclCompileAppendCmd --
sl@0	58	*
sl@0	59	* Procedure called to compile the "append" command.
sl@0	60	*
sl@0	61	* Results:
sl@0	62	* The return value is a standard Tcl result, which is normally TCL_OK
sl@0	63	* unless there was an error while parsing string. If an error occurs
sl@0	64	* then the interpreter's result contains a standard error message. If
sl@0	65	* complation fails because the command requires a second level of
sl@0	66	* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0	67	* command should be compiled "out of line" by emitting code to
sl@0	68	* invoke its command procedure (Tcl_AppendObjCmd) at runtime.
sl@0	69	*
sl@0	70	* Side effects:
sl@0	71	* Instructions are added to envPtr to execute the "append" command
sl@0	72	* at runtime.
sl@0	73	*
sl@0	74	*----------------------------------------------------------------------
sl@0	75	*/
sl@0	76
sl@0	77	int
sl@0	78	TclCompileAppendCmd(interp, parsePtr, envPtr)
sl@0	79	Tcl_Interp interp; / Used for error reporting. */
sl@0	80	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	81	* command created by Tcl_ParseCommand. */
sl@0	82	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	83	{
sl@0	84	Tcl_Token varTokenPtr, valueTokenPtr;
sl@0	85	int simpleVarName, isScalar, localIndex, numWords;
sl@0	86	int code = TCL_OK;
sl@0	87
sl@0	88	#ifdef TCL_TIP280
sl@0	89	/* TIP #280 : Remember the per-word line information of the current
sl@0	90	* command. An index is used instead of a pointer as recursive compilation
sl@0	91	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	92	* the nuloc now, it may change during the course of the function.
sl@0	93	*/
sl@0	94	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	95	int eclIndex = mapPtr->nuloc - 1;
sl@0	96	#endif
sl@0	97
sl@0	98	numWords = parsePtr->numWords;
sl@0	99	if (numWords == 1) {
sl@0	100	Tcl_ResetResult(interp);
sl@0	101	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	102	"wrong # args: should be \"append varName ?value value ...?\"",
sl@0	103	-1);
sl@0	104	return TCL_ERROR;
sl@0	105	} else if (numWords == 2) {
sl@0	106	/*
sl@0	107	* append varName === set varName
sl@0	108	*/
sl@0	109	return TclCompileSetCmd(interp, parsePtr, envPtr);
sl@0	110	} else if (numWords > 3) {
sl@0	111	/*
sl@0	112	* APPEND instructions currently only handle one value
sl@0	113	*/
sl@0	114	return TCL_OUT_LINE_COMPILE;
sl@0	115	}
sl@0	116
sl@0	117	/*
sl@0	118	* Decide if we can use a frame slot for the var/array name or if we
sl@0	119	* need to emit code to compute and push the name at runtime. We use a
sl@0	120	* frame slot (entry in the array of local vars) if we are compiling a
sl@0	121	* procedure body and if the name is simple text that does not include
sl@0	122	* namespace qualifiers.
sl@0	123	*/
sl@0	124
sl@0	125	varTokenPtr = parsePtr->tokenPtr
sl@0	126	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	127
sl@0	128	code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
sl@0	129	#ifndef TCL_TIP280
sl@0	130	&localIndex, &simpleVarName, &isScalar);
sl@0	131	#else
sl@0	132	&localIndex, &simpleVarName, &isScalar,
sl@0	133	mapPtr->loc [eclIndex].line [1]);
sl@0	134	#endif
sl@0	135	if (code != TCL_OK) {
sl@0	136	goto done;
sl@0	137	}
sl@0	138
sl@0	139	/*
sl@0	140	* We are doing an assignment, otherwise TclCompileSetCmd was called,
sl@0	141	* so push the new value. This will need to be extended to push a
sl@0	142	* value for each argument.
sl@0	143	*/
sl@0	144
sl@0	145	if (numWords > 2) {
sl@0	146	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	147	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	148	TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0	149	valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
sl@0	150	} else {
sl@0	151	#ifdef TCL_TIP280
sl@0	152	envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0	153	#endif
sl@0	154	code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0	155	valueTokenPtr->numComponents, envPtr);
sl@0	156	if (code != TCL_OK) {
sl@0	157	goto done;
sl@0	158	}
sl@0	159	}
sl@0	160	}
sl@0	161
sl@0	162	/*
sl@0	163	* Emit instructions to set/get the variable.
sl@0	164	*/
sl@0	165
sl@0	166	if (simpleVarName) {
sl@0	167	if (isScalar) {
sl@0	168	if (localIndex >= 0) {
sl@0	169	if (localIndex <= 255) {
sl@0	170	TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
sl@0	171	} else {
sl@0	172	TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
sl@0	173	}
sl@0	174	} else {
sl@0	175	TclEmitOpcode(INST_APPEND_STK, envPtr);
sl@0	176	}
sl@0	177	} else {
sl@0	178	if (localIndex >= 0) {
sl@0	179	if (localIndex <= 255) {
sl@0	180	TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
sl@0	181	} else {
sl@0	182	TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
sl@0	183	}
sl@0	184	} else {
sl@0	185	TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
sl@0	186	}
sl@0	187	}
sl@0	188	} else {
sl@0	189	TclEmitOpcode(INST_APPEND_STK, envPtr);
sl@0	190	}
sl@0	191
sl@0	192	done:
sl@0	193	return code;
sl@0	194	}
sl@0	195
sl@0	196	/*
sl@0	197	*----------------------------------------------------------------------
sl@0	198	*
sl@0	199	* TclCompileBreakCmd --
sl@0	200	*
sl@0	201	* Procedure called to compile the "break" command.
sl@0	202	*
sl@0	203	* Results:
sl@0	204	* The return value is a standard Tcl result, which is TCL_OK unless
sl@0	205	* there was an error during compilation. If an error occurs then
sl@0	206	* the interpreter's result contains a standard error message.
sl@0	207	*
sl@0	208	* Side effects:
sl@0	209	* Instructions are added to envPtr to execute the "break" command
sl@0	210	* at runtime.
sl@0	211	*
sl@0	212	*----------------------------------------------------------------------
sl@0	213	*/
sl@0	214
sl@0	215	int
sl@0	216	TclCompileBreakCmd(interp, parsePtr, envPtr)
sl@0	217	Tcl_Interp interp; / Used for error reporting. */
sl@0	218	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	219	* command created by Tcl_ParseCommand. */
sl@0	220	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	221	{
sl@0	222	if (parsePtr->numWords != 1) {
sl@0	223	Tcl_ResetResult(interp);
sl@0	224	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	225	"wrong # args: should be \"break\"", -1);
sl@0	226	return TCL_ERROR;
sl@0	227	}
sl@0	228
sl@0	229	/*
sl@0	230	* Emit a break instruction.
sl@0	231	*/
sl@0	232
sl@0	233	TclEmitOpcode(INST_BREAK, envPtr);
sl@0	234	return TCL_OK;
sl@0	235	}
sl@0	236
sl@0	237	/*
sl@0	238	*----------------------------------------------------------------------
sl@0	239	*
sl@0	240	* TclCompileCatchCmd --
sl@0	241	*
sl@0	242	* Procedure called to compile the "catch" command.
sl@0	243	*
sl@0	244	* Results:
sl@0	245	* The return value is a standard Tcl result, which is TCL_OK if
sl@0	246	* compilation was successful. If an error occurs then the
sl@0	247	* interpreter's result contains a standard error message and TCL_ERROR
sl@0	248	* is returned. If the command is too complex for TclCompileCatchCmd,
sl@0	249	* TCL_OUT_LINE_COMPILE is returned indicating that the catch command
sl@0	250	* should be compiled "out of line" by emitting code to invoke its
sl@0	251	* command procedure at runtime.
sl@0	252	*
sl@0	253	* Side effects:
sl@0	254	* Instructions are added to envPtr to execute the "catch" command
sl@0	255	* at runtime.
sl@0	256	*
sl@0	257	*----------------------------------------------------------------------
sl@0	258	*/
sl@0	259
sl@0	260	int
sl@0	261	TclCompileCatchCmd(interp, parsePtr, envPtr)
sl@0	262	Tcl_Interp interp; / Used for error reporting. */
sl@0	263	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	264	* command created by Tcl_ParseCommand. */
sl@0	265	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	266	{
sl@0	267	JumpFixup jumpFixup;
sl@0	268	Tcl_Token cmdTokenPtr, nameTokenPtr;
sl@0	269	CONST char *name;
sl@0	270	int localIndex, nameChars, range, startOffset, jumpDist;
sl@0	271	int code;
sl@0	272	int savedStackDepth = envPtr->currStackDepth;
sl@0	273
sl@0	274	#ifdef TCL_TIP280
sl@0	275	/* TIP #280 : Remember the per-word line information of the current
sl@0	276	* command. An index is used instead of a pointer as recursive compilation
sl@0	277	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	278	* the nuloc now, it may change during the course of the function.
sl@0	279	*/
sl@0	280	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	281	int eclIndex = mapPtr->nuloc - 1;
sl@0	282	#endif
sl@0	283
sl@0	284	if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
sl@0	285	Tcl_ResetResult(interp);
sl@0	286	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	287	"wrong # args: should be \"catch command ?varName?\"", -1);
sl@0	288	return TCL_ERROR;
sl@0	289	}
sl@0	290
sl@0	291	/*
sl@0	292	* If a variable was specified and the catch command is at global level
sl@0	293	* (not in a procedure), don't compile it inline: the payoff is
sl@0	294	* too small.
sl@0	295	*/
sl@0	296
sl@0	297	if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
sl@0	298	return TCL_OUT_LINE_COMPILE;
sl@0	299	}
sl@0	300
sl@0	301	/*
sl@0	302	* Make sure the variable name, if any, has no substitutions and just
sl@0	303	* refers to a local scaler.
sl@0	304	*/
sl@0	305
sl@0	306	localIndex = -1;
sl@0	307	cmdTokenPtr = parsePtr->tokenPtr
sl@0	308	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	309	if (parsePtr->numWords == 3) {
sl@0	310	nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);
sl@0	311	if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	312	name = nameTokenPtr[1].start;
sl@0	313	nameChars = nameTokenPtr[1].size;
sl@0	314	if (!TclIsLocalScalar(name, nameChars)) {
sl@0	315	return TCL_OUT_LINE_COMPILE;
sl@0	316	}
sl@0	317	localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
sl@0	318	nameTokenPtr[1].size, /create/ 1,
sl@0	319	/flags/ VAR_SCALAR, envPtr->procPtr);
sl@0	320	} else {
sl@0	321	return TCL_OUT_LINE_COMPILE;
sl@0	322	}
sl@0	323	}
sl@0	324
sl@0	325	/*
sl@0	326	* We will compile the catch command. Emit a beginCatch instruction at
sl@0	327	* the start of the catch body: the subcommand it controls.
sl@0	328	*/
sl@0	329
sl@0	330	envPtr->exceptDepth++;
sl@0	331	envPtr->maxExceptDepth =
sl@0	332	TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0	333	range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
sl@0	334	TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
sl@0	335
sl@0	336	/*
sl@0	337	* If the body is a simple word, compile the instructions to
sl@0	338	* eval it. Otherwise, compile instructions to substitute its
sl@0	339	* text without catching, a catch instruction that resets the
sl@0	340	* stack to what it was before substituting the body, and then
sl@0	341	* an instruction to eval the body. Care has to be taken to
sl@0	342	* register the correct startOffset for the catch range so that
sl@0	343	* errors in the substitution are not catched [Bug 219184]
sl@0	344	*/
sl@0	345
sl@0	346	#ifdef TCL_TIP280
sl@0	347	envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0	348	#endif
sl@0	349	if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	350	startOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	351	code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
sl@0	352	} else {
sl@0	353	code = TclCompileTokens(interp, cmdTokenPtr+1,
sl@0	354	cmdTokenPtr->numComponents, envPtr);
sl@0	355	startOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	356	TclEmitOpcode(INST_EVAL_STK, envPtr);
sl@0	357	}
sl@0	358	envPtr->exceptArrayPtr[range].codeOffset = startOffset;
sl@0	359
sl@0	360	if (code != TCL_OK) {
sl@0	361	code = TCL_OUT_LINE_COMPILE;
sl@0	362	goto done;
sl@0	363	}
sl@0	364	envPtr->exceptArrayPtr[range].numCodeBytes =
sl@0	365	(envPtr->codeNext - envPtr->codeStart) - startOffset;
sl@0	366
sl@0	367	/*
sl@0	368	* The "no errors" epilogue code: store the body's result into the
sl@0	369	* variable (if any), push "0" (TCL_OK) as the catch's "no error"
sl@0	370	* result, and jump around the "error case" code.
sl@0	371	*/
sl@0	372
sl@0	373	if (localIndex != -1) {
sl@0	374	if (localIndex <= 255) {
sl@0	375	TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
sl@0	376	} else {
sl@0	377	TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
sl@0	378	}
sl@0	379	}
sl@0	380	TclEmitOpcode(INST_POP, envPtr);
sl@0	381	TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
sl@0	382	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
sl@0	383
sl@0	384	/*
sl@0	385	* The "error case" code: store the body's result into the variable (if
sl@0	386	* any), then push the error result code. The initial PC offset here is
sl@0	387	* the catch's error target.
sl@0	388	*/
sl@0	389
sl@0	390	envPtr->currStackDepth = savedStackDepth;
sl@0	391	envPtr->exceptArrayPtr[range].catchOffset =
sl@0	392	(envPtr->codeNext - envPtr->codeStart);
sl@0	393	if (localIndex != -1) {
sl@0	394	TclEmitOpcode(INST_PUSH_RESULT, envPtr);
sl@0	395	if (localIndex <= 255) {
sl@0	396	TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
sl@0	397	} else {
sl@0	398	TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
sl@0	399	}
sl@0	400	TclEmitOpcode(INST_POP, envPtr);
sl@0	401	}
sl@0	402	TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
sl@0	403
sl@0	404
sl@0	405	/*
sl@0	406	* Update the target of the jump after the "no errors" code, then emit
sl@0	407	* an endCatch instruction at the end of the catch command.
sl@0	408	*/
sl@0	409
sl@0	410	jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0	411	- jumpFixup.codeOffset;
sl@0	412	if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
sl@0	413	panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
sl@0	414	}
sl@0	415	TclEmitOpcode(INST_END_CATCH, envPtr);
sl@0	416
sl@0	417	done:
sl@0	418	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	419	envPtr->exceptDepth--;
sl@0	420	return code;
sl@0	421	}
sl@0	422
sl@0	423	/*
sl@0	424	*----------------------------------------------------------------------
sl@0	425	*
sl@0	426	* TclCompileContinueCmd --
sl@0	427	*
sl@0	428	* Procedure called to compile the "continue" command.
sl@0	429	*
sl@0	430	* Results:
sl@0	431	* The return value is a standard Tcl result, which is TCL_OK unless
sl@0	432	* there was an error while parsing string. If an error occurs then
sl@0	433	* the interpreter's result contains a standard error message.
sl@0	434	*
sl@0	435	* Side effects:
sl@0	436	* Instructions are added to envPtr to execute the "continue" command
sl@0	437	* at runtime.
sl@0	438	*
sl@0	439	*----------------------------------------------------------------------
sl@0	440	*/
sl@0	441
sl@0	442	int
sl@0	443	TclCompileContinueCmd(interp, parsePtr, envPtr)
sl@0	444	Tcl_Interp interp; / Used for error reporting. */
sl@0	445	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	446	* command created by Tcl_ParseCommand. */
sl@0	447	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	448	{
sl@0	449	/*
sl@0	450	* There should be no argument after the "continue".
sl@0	451	*/
sl@0	452
sl@0	453	if (parsePtr->numWords != 1) {
sl@0	454	Tcl_ResetResult(interp);
sl@0	455	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	456	"wrong # args: should be \"continue\"", -1);
sl@0	457	return TCL_ERROR;
sl@0	458	}
sl@0	459
sl@0	460	/*
sl@0	461	* Emit a continue instruction.
sl@0	462	*/
sl@0	463
sl@0	464	TclEmitOpcode(INST_CONTINUE, envPtr);
sl@0	465	return TCL_OK;
sl@0	466	}
sl@0	467
sl@0	468	/*
sl@0	469	*----------------------------------------------------------------------
sl@0	470	*
sl@0	471	* TclCompileExprCmd --
sl@0	472	*
sl@0	473	* Procedure called to compile the "expr" command.
sl@0	474	*
sl@0	475	* Results:
sl@0	476	* The return value is a standard Tcl result, which is TCL_OK
sl@0	477	* unless there was an error while parsing string. If an error occurs
sl@0	478	* then the interpreter's result contains a standard error message.
sl@0	479	*
sl@0	480	* Side effects:
sl@0	481	* Instructions are added to envPtr to execute the "expr" command
sl@0	482	* at runtime.
sl@0	483	*
sl@0	484	*----------------------------------------------------------------------
sl@0	485	*/
sl@0	486
sl@0	487	int
sl@0	488	TclCompileExprCmd(interp, parsePtr, envPtr)
sl@0	489	Tcl_Interp interp; / Used for error reporting. */
sl@0	490	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	491	* command created by Tcl_ParseCommand. */
sl@0	492	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	493	{
sl@0	494	Tcl_Token *firstWordPtr;
sl@0	495
sl@0	496	if (parsePtr->numWords == 1) {
sl@0	497	Tcl_ResetResult(interp);
sl@0	498	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	499	"wrong # args: should be \"expr arg ?arg ...?\"", -1);
sl@0	500	return TCL_ERROR;
sl@0	501	}
sl@0	502
sl@0	503	#ifdef TCL_TIP280
sl@0	504	/* TIP #280 : Use the per-word line information of the current command.
sl@0	505	*/
sl@0	506	envPtr->line = envPtr->extCmdMapPtr->loc [envPtr->extCmdMapPtr->nuloc - 1].line [1];
sl@0	507	#endif
sl@0	508	firstWordPtr = parsePtr->tokenPtr
sl@0	509	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	510	return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
sl@0	511	envPtr);
sl@0	512	}
sl@0	513
sl@0	514	/*
sl@0	515	*----------------------------------------------------------------------
sl@0	516	*
sl@0	517	* TclCompileForCmd --
sl@0	518	*
sl@0	519	* Procedure called to compile the "for" command.
sl@0	520	*
sl@0	521	* Results:
sl@0	522	* The return value is a standard Tcl result, which is TCL_OK unless
sl@0	523	* there was an error while parsing string. If an error occurs then
sl@0	524	* the interpreter's result contains a standard error message.
sl@0	525	*
sl@0	526	* Side effects:
sl@0	527	* Instructions are added to envPtr to execute the "for" command
sl@0	528	* at runtime.
sl@0	529	*
sl@0	530	*----------------------------------------------------------------------
sl@0	531	*/
sl@0	532	int
sl@0	533	TclCompileForCmd(interp, parsePtr, envPtr)
sl@0	534	Tcl_Interp interp; / Used for error reporting. */
sl@0	535	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	536	* command created by Tcl_ParseCommand. */
sl@0	537	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	538	{
sl@0	539	Tcl_Token startTokenPtr, testTokenPtr, nextTokenPtr, bodyTokenPtr;
sl@0	540	JumpFixup jumpEvalCondFixup;
sl@0	541	int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
sl@0	542	int bodyRange, nextRange, code;
sl@0	543	char buffer[32 + TCL_INTEGER_SPACE];
sl@0	544	int savedStackDepth = envPtr->currStackDepth;
sl@0	545
sl@0	546	#ifdef TCL_TIP280
sl@0	547	/* TIP #280 : Remember the per-word line information of the current
sl@0	548	* command. An index is used instead of a pointer as recursive compilation
sl@0	549	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	550	* the nuloc now, it may change during the course of the function.
sl@0	551	*/
sl@0	552	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	553	int eclIndex = mapPtr->nuloc - 1;
sl@0	554	#endif
sl@0	555
sl@0	556	if (parsePtr->numWords != 5) {
sl@0	557	Tcl_ResetResult(interp);
sl@0	558	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	559	"wrong # args: should be \"for start test next command\"", -1);
sl@0	560	return TCL_ERROR;
sl@0	561	}
sl@0	562
sl@0	563	/*
sl@0	564	* If the test expression requires substitutions, don't compile the for
sl@0	565	* command inline. E.g., the expression might cause the loop to never
sl@0	566	* execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
sl@0	567	*/
sl@0	568
sl@0	569	startTokenPtr = parsePtr->tokenPtr
sl@0	570	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	571	testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
sl@0	572	if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0	573	return TCL_OUT_LINE_COMPILE;
sl@0	574	}
sl@0	575
sl@0	576	/*
sl@0	577	* Bail out also if the body or the next expression require substitutions
sl@0	578	* in order to insure correct behaviour [Bug 219166]
sl@0	579	*/
sl@0	580
sl@0	581	nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
sl@0	582	bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
sl@0	583	if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
sl@0	584	\|\| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
sl@0	585	return TCL_OUT_LINE_COMPILE;
sl@0	586	}
sl@0	587
sl@0	588	/*
sl@0	589	* Create ExceptionRange records for the body and the "next" command.
sl@0	590	* The "next" command's ExceptionRange supports break but not continue
sl@0	591	* (and has a -1 continueOffset).
sl@0	592	*/
sl@0	593
sl@0	594	envPtr->exceptDepth++;
sl@0	595	envPtr->maxExceptDepth =
sl@0	596	TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0	597	bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0	598	nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0	599
sl@0	600	/*
sl@0	601	* Inline compile the initial command.
sl@0	602	*/
sl@0	603
sl@0	604	#ifdef TCL_TIP280
sl@0	605	envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0	606	#endif
sl@0	607	code = TclCompileCmdWord(interp, startTokenPtr+1,
sl@0	608	startTokenPtr->numComponents, envPtr);
sl@0	609	if (code != TCL_OK) {
sl@0	610	if (code == TCL_ERROR) {
sl@0	611	Tcl_AddObjErrorInfo(interp,
sl@0	612	"\n (\"for\" initial command)", -1);
sl@0	613	}
sl@0	614	goto done;
sl@0	615	}
sl@0	616	TclEmitOpcode(INST_POP, envPtr);
sl@0	617
sl@0	618	/*
sl@0	619	* Jump to the evaluation of the condition. This code uses the "loop
sl@0	620	* rotation" optimisation (which eliminates one branch from the loop).
sl@0	621	* "for start cond next body" produces then:
sl@0	622	* start
sl@0	623	* goto A
sl@0	624	* B: body : bodyCodeOffset
sl@0	625	* next : nextCodeOffset, continueOffset
sl@0	626	* A: cond -> result : testCodeOffset
sl@0	627	* if (result) goto B
sl@0	628	*/
sl@0	629
sl@0	630	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
sl@0	631
sl@0	632	/*
sl@0	633	* Compile the loop body.
sl@0	634	*/
sl@0	635
sl@0	636	bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	637
sl@0	638	#ifdef TCL_TIP280
sl@0	639	envPtr->line = mapPtr->loc [eclIndex].line [4];
sl@0	640	#endif
sl@0	641	code = TclCompileCmdWord(interp, bodyTokenPtr+1,
sl@0	642	bodyTokenPtr->numComponents, envPtr);
sl@0	643	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	644	if (code != TCL_OK) {
sl@0	645	if (code == TCL_ERROR) {
sl@0	646	sprintf(buffer, "\n (\"for\" body line %d)",
sl@0	647	interp->errorLine);
sl@0	648	Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0	649	}
sl@0	650	goto done;
sl@0	651	}
sl@0	652	envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
sl@0	653	(envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0	654	TclEmitOpcode(INST_POP, envPtr);
sl@0	655
sl@0	656
sl@0	657	/*
sl@0	658	* Compile the "next" subcommand.
sl@0	659	*/
sl@0	660
sl@0	661	nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	662
sl@0	663	#ifdef TCL_TIP280
sl@0	664	envPtr->line = mapPtr->loc [eclIndex].line [3];
sl@0	665	#endif
sl@0	666	envPtr->currStackDepth = savedStackDepth;
sl@0	667	code = TclCompileCmdWord(interp, nextTokenPtr+1,
sl@0	668	nextTokenPtr->numComponents, envPtr);
sl@0	669	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	670	if (code != TCL_OK) {
sl@0	671	if (code == TCL_ERROR) {
sl@0	672	Tcl_AddObjErrorInfo(interp,
sl@0	673	"\n (\"for\" loop-end command)", -1);
sl@0	674	}
sl@0	675	goto done;
sl@0	676	}
sl@0	677	envPtr->exceptArrayPtr[nextRange].numCodeBytes =
sl@0	678	(envPtr->codeNext - envPtr->codeStart)
sl@0	679	- nextCodeOffset;
sl@0	680	TclEmitOpcode(INST_POP, envPtr);
sl@0	681	envPtr->currStackDepth = savedStackDepth;
sl@0	682
sl@0	683	/*
sl@0	684	* Compile the test expression then emit the conditional jump that
sl@0	685	* terminates the for.
sl@0	686	*/
sl@0	687
sl@0	688	testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	689
sl@0	690	jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
sl@0	691	if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
sl@0	692	bodyCodeOffset += 3;
sl@0	693	nextCodeOffset += 3;
sl@0	694	testCodeOffset += 3;
sl@0	695	}
sl@0	696	#ifdef TCL_TIP280
sl@0	697	envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0	698	#endif
sl@0	699	envPtr->currStackDepth = savedStackDepth;
sl@0	700	code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
sl@0	701	if (code != TCL_OK) {
sl@0	702	if (code == TCL_ERROR) {
sl@0	703	Tcl_AddObjErrorInfo(interp,
sl@0	704	"\n (\"for\" test expression)", -1);
sl@0	705	}
sl@0	706	goto done;
sl@0	707	}
sl@0	708	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	709
sl@0	710	jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0	711	if (jumpDist > 127) {
sl@0	712	TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
sl@0	713	} else {
sl@0	714	TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
sl@0	715	}
sl@0	716
sl@0	717	/*
sl@0	718	* Set the loop's offsets and break target.
sl@0	719	*/
sl@0	720
sl@0	721	envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
sl@0	722	envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;
sl@0	723
sl@0	724	envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
sl@0	725
sl@0	726	envPtr->exceptArrayPtr[bodyRange].breakOffset =
sl@0	727	envPtr->exceptArrayPtr[nextRange].breakOffset =
sl@0	728	(envPtr->codeNext - envPtr->codeStart);
sl@0	729
sl@0	730	/*
sl@0	731	* The for command's result is an empty string.
sl@0	732	*/
sl@0	733
sl@0	734	envPtr->currStackDepth = savedStackDepth;
sl@0	735	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0	736	code = TCL_OK;
sl@0	737
sl@0	738	done:
sl@0	739	envPtr->exceptDepth--;
sl@0	740	return code;
sl@0	741	}
sl@0	742
sl@0	743	/*
sl@0	744	*----------------------------------------------------------------------
sl@0	745	*
sl@0	746	* TclCompileForeachCmd --
sl@0	747	*
sl@0	748	* Procedure called to compile the "foreach" command.
sl@0	749	*
sl@0	750	* Results:
sl@0	751	* The return value is a standard Tcl result, which is TCL_OK if
sl@0	752	* compilation was successful. If an error occurs then the
sl@0	753	* interpreter's result contains a standard error message and TCL_ERROR
sl@0	754	* is returned. If the command is too complex for TclCompileForeachCmd,
sl@0	755	* TCL_OUT_LINE_COMPILE is returned indicating that the foreach command
sl@0	756	* should be compiled "out of line" by emitting code to invoke its
sl@0	757	* command procedure at runtime.
sl@0	758	*
sl@0	759	* Side effects:
sl@0	760	* Instructions are added to envPtr to execute the "foreach" command
sl@0	761	* at runtime.
sl@0	762	*
sl@0	763	n*----------------------------------------------------------------------
sl@0	764	*/
sl@0	765
sl@0	766	int
sl@0	767	TclCompileForeachCmd(interp, parsePtr, envPtr)
sl@0	768	Tcl_Interp interp; / Used for error reporting. */
sl@0	769	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	770	* command created by Tcl_ParseCommand. */
sl@0	771	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	772	{
sl@0	773	Proc *procPtr = envPtr->procPtr;
sl@0	774	ForeachInfo infoPtr; / Points to the structure describing this
sl@0	775	* foreach command. Stored in a AuxData
sl@0	776	* record in the ByteCode. */
sl@0	777	int firstValueTemp; /* Index of the first temp var in the frame
sl@0	778	* used to point to a value list. */
sl@0	779	int loopCtTemp; /* Index of temp var holding the loop's
sl@0	780	* iteration count. */
sl@0	781	Tcl_Token tokenPtr, bodyTokenPtr;
sl@0	782	unsigned char *jumpPc;
sl@0	783	JumpFixup jumpFalseFixup;
sl@0	784	int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
sl@0	785	int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
sl@0	786	char buffer[32 + TCL_INTEGER_SPACE];
sl@0	787	int savedStackDepth = envPtr->currStackDepth;
sl@0	788
sl@0	789	#ifdef TCL_TIP280
sl@0	790	/* TIP #280 : Remember the per-word line information of the current
sl@0	791	* command. An index is used instead of a pointer as recursive compilation
sl@0	792	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	793	* the nuloc now, it may change during the course of the function.
sl@0	794	*/
sl@0	795	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	796	int eclIndex = mapPtr->nuloc - 1;
sl@0	797	int bodyIndex;
sl@0	798	#endif
sl@0	799
sl@0	800	/*
sl@0	801	* We parse the variable list argument words and create two arrays:
sl@0	802	* varcList[i] is number of variables in i-th var list
sl@0	803	* varvList[i] points to array of var names in i-th var list
sl@0	804	*/
sl@0	805
sl@0	806	#define STATIC_VAR_LIST_SIZE 5
sl@0	807	int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
sl@0	808	CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
sl@0	809	int *varcList = varcListStaticSpace;
sl@0	810	CONST char ***varvList = varvListStaticSpace;
sl@0	811
sl@0	812	/*
sl@0	813	* If the foreach command isn't in a procedure, don't compile it inline:
sl@0	814	* the payoff is too small.
sl@0	815	*/
sl@0	816
sl@0	817	if (procPtr == NULL) {
sl@0	818	return TCL_OUT_LINE_COMPILE;
sl@0	819	}
sl@0	820
sl@0	821	numWords = parsePtr->numWords;
sl@0	822	if ((numWords < 4) \|\| (numWords%2 != 0)) {
sl@0	823	Tcl_ResetResult(interp);
sl@0	824	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	825	"wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
sl@0	826	return TCL_ERROR;
sl@0	827	}
sl@0	828
sl@0	829	/*
sl@0	830	* Bail out if the body requires substitutions
sl@0	831	* in order to insure correct behaviour [Bug 219166]
sl@0	832	*/
sl@0	833	for (i = 0, tokenPtr = parsePtr->tokenPtr;
sl@0	834	i < numWords-1;
sl@0	835	i++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0	836	}
sl@0	837	bodyTokenPtr = tokenPtr;
sl@0	838	if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0	839	return TCL_OUT_LINE_COMPILE;
sl@0	840	}
sl@0	841	#ifdef TCL_TIP280
sl@0	842	bodyIndex = i-1;
sl@0	843	#endif
sl@0	844
sl@0	845	/*
sl@0	846	* Allocate storage for the varcList and varvList arrays if necessary.
sl@0	847	*/
sl@0	848
sl@0	849	numLists = (numWords - 2)/2;
sl@0	850	if (numLists > STATIC_VAR_LIST_SIZE) {
sl@0	851	varcList = (int ) ckalloc(numLists sizeof(int));
sl@0	852	varvList = (CONST char **) ckalloc(numLists sizeof(CONST char **));
sl@0	853	}
sl@0	854	for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0	855	varcList[loopIndex] = 0;
sl@0	856	varvList[loopIndex] = NULL;
sl@0	857	}
sl@0	858
sl@0	859	/*
sl@0	860	* Set the exception stack depth.
sl@0	861	*/
sl@0	862
sl@0	863	envPtr->exceptDepth++;
sl@0	864	envPtr->maxExceptDepth =
sl@0	865	TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0	866
sl@0	867	/*
sl@0	868	* Break up each var list and set the varcList and varvList arrays.
sl@0	869	* Don't compile the foreach inline if any var name needs substitutions
sl@0	870	* or isn't a scalar, or if any var list needs substitutions.
sl@0	871	*/
sl@0	872
sl@0	873	loopIndex = 0;
sl@0	874	for (i = 0, tokenPtr = parsePtr->tokenPtr;
sl@0	875	i < numWords-1;
sl@0	876	i++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0	877	if (i%2 == 1) {
sl@0	878	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0	879	code = TCL_OUT_LINE_COMPILE;
sl@0	880	goto done;
sl@0	881	} else {
sl@0	882	/* Lots of copying going on here. Need a ListObj wizard
sl@0	883	* to show a better way. */
sl@0	884
sl@0	885	Tcl_DString varList;
sl@0	886
sl@0	887	Tcl_DStringInit(&varList);
sl@0	888	Tcl_DStringAppend(&varList, tokenPtr[1].start,
sl@0	889	tokenPtr[1].size);
sl@0	890	code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
sl@0	891	&varcList[loopIndex], &varvList[loopIndex]);
sl@0	892	Tcl_DStringFree(&varList);
sl@0	893	if (code != TCL_OK) {
sl@0	894	goto done;
sl@0	895	}
sl@0	896	numVars = varcList[loopIndex];
sl@0	897
sl@0	898	/*
sl@0	899	* If the variable list is empty, we can enter an infinite
sl@0	900	* loop when the interpreted version would not. Take care to
sl@0	901	* ensure this does not happen. [Bug 1671138]
sl@0	902	*/
sl@0	903
sl@0	904	if (numVars == 0) {
sl@0	905	code = TCL_OUT_LINE_COMPILE;
sl@0	906	goto done;
sl@0	907	}
sl@0	908
sl@0	909	for (j = 0; j < numVars; j++) {
sl@0	910	CONST char *varName = varvList[loopIndex][j];
sl@0	911	if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
sl@0	912	code = TCL_OUT_LINE_COMPILE;
sl@0	913	goto done;
sl@0	914	}
sl@0	915	}
sl@0	916	}
sl@0	917	loopIndex++;
sl@0	918	}
sl@0	919	}
sl@0	920
sl@0	921	/*
sl@0	922	* We will compile the foreach command.
sl@0	923	* Reserve (numLists + 1) temporary variables:
sl@0	924	* - numLists temps to hold each value list
sl@0	925	* - 1 temp for the loop counter (index of next element in each list)
sl@0	926	* At this time we don't try to reuse temporaries; if there are two
sl@0	927	* nonoverlapping foreach loops, they don't share any temps.
sl@0	928	*/
sl@0	929
sl@0	930	firstValueTemp = -1;
sl@0	931	for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0	932	tempVar = TclFindCompiledLocal(NULL, /nameChars/ 0,
sl@0	933	/create/ 1, /flags/ VAR_SCALAR, procPtr);
sl@0	934	if (loopIndex == 0) {
sl@0	935	firstValueTemp = tempVar;
sl@0	936	}
sl@0	937	}
sl@0	938	loopCtTemp = TclFindCompiledLocal(NULL, /nameChars/ 0,
sl@0	939	/create/ 1, /flags/ VAR_SCALAR, procPtr);
sl@0	940
sl@0	941	/*
sl@0	942	* Create and initialize the ForeachInfo and ForeachVarList data
sl@0	943	* structures describing this command. Then create a AuxData record
sl@0	944	* pointing to the ForeachInfo structure.
sl@0	945	*/
sl@0	946
sl@0	947	infoPtr = (ForeachInfo *) ckalloc((unsigned)
sl@0	948	(sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
sl@0	949	infoPtr->numLists = numLists;
sl@0	950	infoPtr->firstValueTemp = firstValueTemp;
sl@0	951	infoPtr->loopCtTemp = loopCtTemp;
sl@0	952	for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0	953	ForeachVarList *varListPtr;
sl@0	954	numVars = varcList[loopIndex];
sl@0	955	varListPtr = (ForeachVarList *) ckalloc((unsigned)
sl@0	956	sizeof(ForeachVarList) + (numVars * sizeof(int)));
sl@0	957	varListPtr->numVars = numVars;
sl@0	958	for (j = 0; j < numVars; j++) {
sl@0	959	CONST char *varName = varvList[loopIndex][j];
sl@0	960	int nameChars = strlen(varName);
sl@0	961	varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
sl@0	962	nameChars, /create/ 1, /flags/ VAR_SCALAR, procPtr);
sl@0	963	}
sl@0	964	infoPtr->varLists[loopIndex] = varListPtr;
sl@0	965	}
sl@0	966	infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
sl@0	967
sl@0	968	/*
sl@0	969	* Evaluate then store each value list in the associated temporary.
sl@0	970	*/
sl@0	971
sl@0	972	range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0	973
sl@0	974	loopIndex = 0;
sl@0	975	for (i = 0, tokenPtr = parsePtr->tokenPtr;
sl@0	976	i < numWords-1;
sl@0	977	i++, tokenPtr += (tokenPtr->numComponents + 1)) {
sl@0	978	if ((i%2 == 0) && (i > 0)) {
sl@0	979	#ifdef TCL_TIP280
sl@0	980	envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0	981	#endif
sl@0	982	code = TclCompileTokens(interp, tokenPtr+1,
sl@0	983	tokenPtr->numComponents, envPtr);
sl@0	984	if (code != TCL_OK) {
sl@0	985	goto done;
sl@0	986	}
sl@0	987
sl@0	988	tempVar = (firstValueTemp + loopIndex);
sl@0	989	if (tempVar <= 255) {
sl@0	990	TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
sl@0	991	} else {
sl@0	992	TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
sl@0	993	}
sl@0	994	TclEmitOpcode(INST_POP, envPtr);
sl@0	995	loopIndex++;
sl@0	996	}
sl@0	997	}
sl@0	998
sl@0	999	/*
sl@0	1000	* Initialize the temporary var that holds the count of loop iterations.
sl@0	1001	*/
sl@0	1002
sl@0	1003	TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
sl@0	1004
sl@0	1005	/*
sl@0	1006	* Top of loop code: assign each loop variable and check whether
sl@0	1007	* to terminate the loop.
sl@0	1008	*/
sl@0	1009
sl@0	1010	envPtr->exceptArrayPtr[range].continueOffset =
sl@0	1011	(envPtr->codeNext - envPtr->codeStart);
sl@0	1012	TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
sl@0	1013	TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
sl@0	1014
sl@0	1015	/*
sl@0	1016	* Inline compile the loop body.
sl@0	1017	*/
sl@0	1018
sl@0	1019	#ifdef TCL_TIP280
sl@0	1020	envPtr->line = mapPtr->loc [eclIndex].line [bodyIndex];
sl@0	1021	#endif
sl@0	1022	envPtr->exceptArrayPtr[range].codeOffset =
sl@0	1023	(envPtr->codeNext - envPtr->codeStart);
sl@0	1024	code = TclCompileCmdWord(interp, bodyTokenPtr+1,
sl@0	1025	bodyTokenPtr->numComponents, envPtr);
sl@0	1026	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	1027	if (code != TCL_OK) {
sl@0	1028	if (code == TCL_ERROR) {
sl@0	1029	sprintf(buffer, "\n (\"foreach\" body line %d)",
sl@0	1030	interp->errorLine);
sl@0	1031	Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0	1032	}
sl@0	1033	goto done;
sl@0	1034	}
sl@0	1035	envPtr->exceptArrayPtr[range].numCodeBytes =
sl@0	1036	(envPtr->codeNext - envPtr->codeStart)
sl@0	1037	- envPtr->exceptArrayPtr[range].codeOffset;
sl@0	1038	TclEmitOpcode(INST_POP, envPtr);
sl@0	1039
sl@0	1040	/*
sl@0	1041	* Jump back to the test at the top of the loop. Generate a 4 byte jump
sl@0	1042	* if the distance to the test is > 120 bytes. This is conservative and
sl@0	1043	* ensures that we won't have to replace this jump if we later need to
sl@0	1044	* replace the ifFalse jump with a 4 byte jump.
sl@0	1045	*/
sl@0	1046
sl@0	1047	jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	1048	jumpBackDist =
sl@0	1049	(jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
sl@0	1050	if (jumpBackDist > 120) {
sl@0	1051	TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
sl@0	1052	} else {
sl@0	1053	TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
sl@0	1054	}
sl@0	1055
sl@0	1056	/*
sl@0	1057	* Fix the target of the jump after the foreach_step test.
sl@0	1058	*/
sl@0	1059
sl@0	1060	jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0	1061	- jumpFalseFixup.codeOffset;
sl@0	1062	if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
sl@0	1063	/*
sl@0	1064	* Update the loop body's starting PC offset since it moved down.
sl@0	1065	*/
sl@0	1066
sl@0	1067	envPtr->exceptArrayPtr[range].codeOffset += 3;
sl@0	1068
sl@0	1069	/*
sl@0	1070	* Update the jump back to the test at the top of the loop since it
sl@0	1071	* also moved down 3 bytes.
sl@0	1072	*/
sl@0	1073
sl@0	1074	jumpBackOffset += 3;
sl@0	1075	jumpPc = (envPtr->codeStart + jumpBackOffset);
sl@0	1076	jumpBackDist += 3;
sl@0	1077	if (jumpBackDist > 120) {
sl@0	1078	TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
sl@0	1079	} else {
sl@0	1080	TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
sl@0	1081	}
sl@0	1082	}
sl@0	1083
sl@0	1084	/*
sl@0	1085	* Set the loop's break target.
sl@0	1086	*/
sl@0	1087
sl@0	1088	envPtr->exceptArrayPtr[range].breakOffset =
sl@0	1089	(envPtr->codeNext - envPtr->codeStart);
sl@0	1090
sl@0	1091	/*
sl@0	1092	* The foreach command's result is an empty string.
sl@0	1093	*/
sl@0	1094
sl@0	1095	envPtr->currStackDepth = savedStackDepth;
sl@0	1096	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0	1097	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	1098
sl@0	1099	done:
sl@0	1100	for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
sl@0	1101	if (varvList[loopIndex] != (CONST char **) NULL) {
sl@0	1102	ckfree((char *) varvList[loopIndex]);
sl@0	1103	}
sl@0	1104	}
sl@0	1105	if (varcList != varcListStaticSpace) {
sl@0	1106	ckfree((char *) varcList);
sl@0	1107	ckfree((char *) varvList);
sl@0	1108	}
sl@0	1109	envPtr->exceptDepth--;
sl@0	1110	return code;
sl@0	1111	}
sl@0	1112
sl@0	1113	/*
sl@0	1114	*----------------------------------------------------------------------
sl@0	1115	*
sl@0	1116	* DupForeachInfo --
sl@0	1117	*
sl@0	1118	* This procedure duplicates a ForeachInfo structure created as
sl@0	1119	* auxiliary data during the compilation of a foreach command.
sl@0	1120	*
sl@0	1121	* Results:
sl@0	1122	* A pointer to a newly allocated copy of the existing ForeachInfo
sl@0	1123	* structure is returned.
sl@0	1124	*
sl@0	1125	* Side effects:
sl@0	1126	* Storage for the copied ForeachInfo record is allocated. If the
sl@0	1127	* original ForeachInfo structure pointed to any ForeachVarList
sl@0	1128	* records, these structures are also copied and pointers to them
sl@0	1129	* are stored in the new ForeachInfo record.
sl@0	1130	*
sl@0	1131	*----------------------------------------------------------------------
sl@0	1132	*/
sl@0	1133
sl@0	1134	static ClientData
sl@0	1135	DupForeachInfo(clientData)
sl@0	1136	ClientData clientData; /* The foreach command's compilation
sl@0	1137	* auxiliary data to duplicate. */
sl@0	1138	{
sl@0	1139	register ForeachInfo srcPtr = (ForeachInfo ) clientData;
sl@0	1140	ForeachInfo *dupPtr;
sl@0	1141	register ForeachVarList srcListPtr, dupListPtr;
sl@0	1142	int numLists = srcPtr->numLists;
sl@0	1143	int numVars, i, j;
sl@0	1144
sl@0	1145	dupPtr = (ForeachInfo *) ckalloc((unsigned)
sl@0	1146	(sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
sl@0	1147	dupPtr->numLists = numLists;
sl@0	1148	dupPtr->firstValueTemp = srcPtr->firstValueTemp;
sl@0	1149	dupPtr->loopCtTemp = srcPtr->loopCtTemp;
sl@0	1150
sl@0	1151	for (i = 0; i < numLists; i++) {
sl@0	1152	srcListPtr = srcPtr->varLists[i];
sl@0	1153	numVars = srcListPtr->numVars;
sl@0	1154	dupListPtr = (ForeachVarList *) ckalloc((unsigned)
sl@0	1155	sizeof(ForeachVarList) + numVars*sizeof(int));
sl@0	1156	dupListPtr->numVars = numVars;
sl@0	1157	for (j = 0; j < numVars; j++) {
sl@0	1158	dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
sl@0	1159	}
sl@0	1160	dupPtr->varLists[i] = dupListPtr;
sl@0	1161	}
sl@0	1162	return (ClientData) dupPtr;
sl@0	1163	}
sl@0	1164
sl@0	1165	/*
sl@0	1166	*----------------------------------------------------------------------
sl@0	1167	*
sl@0	1168	* FreeForeachInfo --
sl@0	1169	*
sl@0	1170	* Procedure to free a ForeachInfo structure created as auxiliary data
sl@0	1171	* during the compilation of a foreach command.
sl@0	1172	*
sl@0	1173	* Results:
sl@0	1174	* None.
sl@0	1175	*
sl@0	1176	* Side effects:
sl@0	1177	* Storage for the ForeachInfo structure pointed to by the ClientData
sl@0	1178	* argument is freed as is any ForeachVarList record pointed to by the
sl@0	1179	* ForeachInfo structure.
sl@0	1180	*
sl@0	1181	*----------------------------------------------------------------------
sl@0	1182	*/
sl@0	1183
sl@0	1184	static void
sl@0	1185	FreeForeachInfo(clientData)
sl@0	1186	ClientData clientData; /* The foreach command's compilation
sl@0	1187	* auxiliary data to free. */
sl@0	1188	{
sl@0	1189	register ForeachInfo infoPtr = (ForeachInfo ) clientData;
sl@0	1190	register ForeachVarList *listPtr;
sl@0	1191	int numLists = infoPtr->numLists;
sl@0	1192	register int i;
sl@0	1193
sl@0	1194	for (i = 0; i < numLists; i++) {
sl@0	1195	listPtr = infoPtr->varLists[i];
sl@0	1196	ckfree((char *) listPtr);
sl@0	1197	}
sl@0	1198	ckfree((char *) infoPtr);
sl@0	1199	}
sl@0	1200
sl@0	1201	/*
sl@0	1202	*----------------------------------------------------------------------
sl@0	1203	*
sl@0	1204	* TclCompileIfCmd --
sl@0	1205	*
sl@0	1206	* Procedure called to compile the "if" command.
sl@0	1207	*
sl@0	1208	* Results:
sl@0	1209	* The return value is a standard Tcl result, which is TCL_OK if
sl@0	1210	* compilation was successful. If an error occurs then the
sl@0	1211	* interpreter's result contains a standard error message and TCL_ERROR
sl@0	1212	* is returned. If the command is too complex for TclCompileIfCmd,
sl@0	1213	* TCL_OUT_LINE_COMPILE is returned indicating that the if command
sl@0	1214	* should be compiled "out of line" by emitting code to invoke its
sl@0	1215	* command procedure at runtime.
sl@0	1216	*
sl@0	1217	* Side effects:
sl@0	1218	* Instructions are added to envPtr to execute the "if" command
sl@0	1219	* at runtime.
sl@0	1220	*
sl@0	1221	*----------------------------------------------------------------------
sl@0	1222	*/
sl@0	1223	int
sl@0	1224	TclCompileIfCmd(interp, parsePtr, envPtr)
sl@0	1225	Tcl_Interp interp; / Used for error reporting. */
sl@0	1226	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	1227	* command created by Tcl_ParseCommand. */
sl@0	1228	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	1229	{
sl@0	1230	JumpFixupArray jumpFalseFixupArray;
sl@0	1231	/* Used to fix the ifFalse jump after each
sl@0	1232	* test when its target PC is determined. */
sl@0	1233	JumpFixupArray jumpEndFixupArray;
sl@0	1234	/* Used to fix the jump after each "then"
sl@0	1235	* body to the end of the "if" when that PC
sl@0	1236	* is determined. */
sl@0	1237	Tcl_Token tokenPtr, testTokenPtr;
sl@0	1238	int jumpDist, jumpFalseDist;
sl@0	1239	int jumpIndex = 0; /* avoid compiler warning. */
sl@0	1240	int numWords, wordIdx, numBytes, j, code;
sl@0	1241	CONST char *word;
sl@0	1242	char buffer[100];
sl@0	1243	int savedStackDepth = envPtr->currStackDepth;
sl@0	1244	/* Saved stack depth at the start of the first
sl@0	1245	* test; the envPtr current depth is restored
sl@0	1246	* to this value at the start of each test. */
sl@0	1247	int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
sl@0	1248	int boolVal; /* value of static condition */
sl@0	1249	int compileScripts = 1;
sl@0	1250
sl@0	1251	#ifdef TCL_TIP280
sl@0	1252	/* TIP #280 : Remember the per-word line information of the current
sl@0	1253	* command. An index is used instead of a pointer as recursive compilation
sl@0	1254	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	1255	* the nuloc now, it may change during the course of the function.
sl@0	1256	*/
sl@0	1257	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	1258	int eclIndex = mapPtr->nuloc - 1;
sl@0	1259	#endif
sl@0	1260
sl@0	1261	/*
sl@0	1262	* Only compile the "if" command if all arguments are simple
sl@0	1263	* words, in order to insure correct substitution [Bug 219166]
sl@0	1264	*/
sl@0	1265
sl@0	1266	tokenPtr = parsePtr->tokenPtr;
sl@0	1267	wordIdx = 0;
sl@0	1268	numWords = parsePtr->numWords;
sl@0	1269
sl@0	1270	for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
sl@0	1271	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0	1272	return TCL_OUT_LINE_COMPILE;
sl@0	1273	}
sl@0	1274	tokenPtr += 2;
sl@0	1275	}
sl@0	1276
sl@0	1277
sl@0	1278	TclInitJumpFixupArray(&jumpFalseFixupArray);
sl@0	1279	TclInitJumpFixupArray(&jumpEndFixupArray);
sl@0	1280	code = TCL_OK;
sl@0	1281
sl@0	1282	/*
sl@0	1283	* Each iteration of this loop compiles one "if expr ?then? body"
sl@0	1284	* or "elseif expr ?then? body" clause.
sl@0	1285	*/
sl@0	1286
sl@0	1287	tokenPtr = parsePtr->tokenPtr;
sl@0	1288	wordIdx = 0;
sl@0	1289	while (wordIdx < numWords) {
sl@0	1290	/*
sl@0	1291	* Stop looping if the token isn't "if" or "elseif".
sl@0	1292	*/
sl@0	1293
sl@0	1294	word = tokenPtr[1].start;
sl@0	1295	numBytes = tokenPtr[1].size;
sl@0	1296	if ((tokenPtr == parsePtr->tokenPtr)
sl@0	1297	\|\| ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
sl@0	1298	tokenPtr += (tokenPtr->numComponents + 1);
sl@0	1299	wordIdx++;
sl@0	1300	} else {
sl@0	1301	break;
sl@0	1302	}
sl@0	1303	if (wordIdx >= numWords) {
sl@0	1304	sprintf(buffer,
sl@0	1305	"wrong # args: no expression after \"%.*s\" argument",
sl@0	1306	(numBytes > 50 ? 50 : numBytes), word);
sl@0	1307	Tcl_ResetResult(interp);
sl@0	1308	Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
sl@0	1309	code = TCL_ERROR;
sl@0	1310	goto done;
sl@0	1311	}
sl@0	1312
sl@0	1313	/*
sl@0	1314	* Compile the test expression then emit the conditional jump
sl@0	1315	* around the "then" part.
sl@0	1316	*/
sl@0	1317
sl@0	1318	envPtr->currStackDepth = savedStackDepth;
sl@0	1319	testTokenPtr = tokenPtr;
sl@0	1320
sl@0	1321
sl@0	1322	if (realCond) {
sl@0	1323	/*
sl@0	1324	* Find out if the condition is a constant.
sl@0	1325	*/
sl@0	1326
sl@0	1327	Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
sl@0	1328	testTokenPtr[1].size);
sl@0	1329	Tcl_IncrRefCount(boolObj);
sl@0	1330	code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
sl@0	1331	Tcl_DecrRefCount(boolObj);
sl@0	1332	if (code == TCL_OK) {
sl@0	1333	/*
sl@0	1334	* A static condition
sl@0	1335	*/
sl@0	1336	realCond = 0;
sl@0	1337	if (!boolVal) {
sl@0	1338	compileScripts = 0;
sl@0	1339	}
sl@0	1340	} else {
sl@0	1341	Tcl_ResetResult(interp);
sl@0	1342	#ifdef TCL_TIP280
sl@0	1343	envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
sl@0	1344	#endif
sl@0	1345	code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
sl@0	1346	if (code != TCL_OK) {
sl@0	1347	if (code == TCL_ERROR) {
sl@0	1348	Tcl_AddObjErrorInfo(interp,
sl@0	1349	"\n (\"if\" test expression)", -1);
sl@0	1350	}
sl@0	1351	goto done;
sl@0	1352	}
sl@0	1353	if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
sl@0	1354	TclExpandJumpFixupArray(&jumpFalseFixupArray);
sl@0	1355	}
sl@0	1356	jumpIndex = jumpFalseFixupArray.next;
sl@0	1357	jumpFalseFixupArray.next++;
sl@0	1358	TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
sl@0	1359	&(jumpFalseFixupArray.fixup[jumpIndex]));
sl@0	1360	}
sl@0	1361	}
sl@0	1362
sl@0	1363
sl@0	1364	/*
sl@0	1365	* Skip over the optional "then" before the then clause.
sl@0	1366	*/
sl@0	1367
sl@0	1368	tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
sl@0	1369	wordIdx++;
sl@0	1370	if (wordIdx >= numWords) {
sl@0	1371	sprintf(buffer,
sl@0	1372	"wrong # args: no script following \"%.*s\" argument",
sl@0	1373	(testTokenPtr->size > 50 ? 50 : testTokenPtr->size),
sl@0	1374	testTokenPtr->start);
sl@0	1375	Tcl_ResetResult(interp);
sl@0	1376	Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
sl@0	1377	code = TCL_ERROR;
sl@0	1378	goto done;
sl@0	1379	}
sl@0	1380	if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	1381	word = tokenPtr[1].start;
sl@0	1382	numBytes = tokenPtr[1].size;
sl@0	1383	if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
sl@0	1384	tokenPtr += (tokenPtr->numComponents + 1);
sl@0	1385	wordIdx++;
sl@0	1386	if (wordIdx >= numWords) {
sl@0	1387	Tcl_ResetResult(interp);
sl@0	1388	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	1389	"wrong # args: no script following \"then\" argument", -1);
sl@0	1390	code = TCL_ERROR;
sl@0	1391	goto done;
sl@0	1392	}
sl@0	1393	}
sl@0	1394	}
sl@0	1395
sl@0	1396	/*
sl@0	1397	* Compile the "then" command body.
sl@0	1398	*/
sl@0	1399
sl@0	1400	if (compileScripts) {
sl@0	1401	#ifdef TCL_TIP280
sl@0	1402	envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
sl@0	1403	#endif
sl@0	1404	envPtr->currStackDepth = savedStackDepth;
sl@0	1405	code = TclCompileCmdWord(interp, tokenPtr+1,
sl@0	1406	tokenPtr->numComponents, envPtr);
sl@0	1407	if (code != TCL_OK) {
sl@0	1408	if (code == TCL_ERROR) {
sl@0	1409	sprintf(buffer, "\n (\"if\" then script line %d)",
sl@0	1410	interp->errorLine);
sl@0	1411	Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0	1412	}
sl@0	1413	goto done;
sl@0	1414	}
sl@0	1415	}
sl@0	1416
sl@0	1417	if (realCond) {
sl@0	1418	/*
sl@0	1419	* Jump to the end of the "if" command. Both jumpFalseFixupArray and
sl@0	1420	* jumpEndFixupArray are indexed by "jumpIndex".
sl@0	1421	*/
sl@0	1422
sl@0	1423	if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
sl@0	1424	TclExpandJumpFixupArray(&jumpEndFixupArray);
sl@0	1425	}
sl@0	1426	jumpEndFixupArray.next++;
sl@0	1427	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
sl@0	1428	&(jumpEndFixupArray.fixup[jumpIndex]));
sl@0	1429
sl@0	1430	/*
sl@0	1431	* Fix the target of the jumpFalse after the test. Generate a 4 byte
sl@0	1432	* jump if the distance is > 120 bytes. This is conservative, and
sl@0	1433	* ensures that we won't have to replace this jump if we later also
sl@0	1434	* need to replace the proceeding jump to the end of the "if" with a
sl@0	1435	* 4 byte jump.
sl@0	1436	*/
sl@0	1437
sl@0	1438	jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0	1439	- jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
sl@0	1440	if (TclFixupForwardJump(envPtr,
sl@0	1441	&(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
sl@0	1442	/*
sl@0	1443	* Adjust the code offset for the proceeding jump to the end
sl@0	1444	* of the "if" command.
sl@0	1445	*/
sl@0	1446
sl@0	1447	jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
sl@0	1448	}
sl@0	1449	} else if (boolVal) {
sl@0	1450	/*
sl@0	1451	*We were processing an "if 1 {...}"; stop compiling
sl@0	1452	* scripts
sl@0	1453	*/
sl@0	1454
sl@0	1455	compileScripts = 0;
sl@0	1456	} else {
sl@0	1457	/*
sl@0	1458	*We were processing an "if 0 {...}"; reset so that
sl@0	1459	* the rest (elseif, else) is compiled correctly
sl@0	1460	*/
sl@0	1461
sl@0	1462	realCond = 1;
sl@0	1463	compileScripts = 1;
sl@0	1464	}
sl@0	1465
sl@0	1466	tokenPtr += (tokenPtr->numComponents + 1);
sl@0	1467	wordIdx++;
sl@0	1468	}
sl@0	1469
sl@0	1470	/*
sl@0	1471	* Restore the current stack depth in the environment; the
sl@0	1472	* "else" clause (or its default) will add 1 to this.
sl@0	1473	*/
sl@0	1474
sl@0	1475	envPtr->currStackDepth = savedStackDepth;
sl@0	1476
sl@0	1477	/*
sl@0	1478	* Check for the optional else clause. Do not compile
sl@0	1479	* anything if this was an "if 1 {...}" case.
sl@0	1480	*/
sl@0	1481
sl@0	1482	if ((wordIdx < numWords)
sl@0	1483	&& (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
sl@0	1484	/*
sl@0	1485	* There is an else clause. Skip over the optional "else" word.
sl@0	1486	*/
sl@0	1487
sl@0	1488	word = tokenPtr[1].start;
sl@0	1489	numBytes = tokenPtr[1].size;
sl@0	1490	if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
sl@0	1491	tokenPtr += (tokenPtr->numComponents + 1);
sl@0	1492	wordIdx++;
sl@0	1493	if (wordIdx >= numWords) {
sl@0	1494	Tcl_ResetResult(interp);
sl@0	1495	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	1496	"wrong # args: no script following \"else\" argument", -1);
sl@0	1497	code = TCL_ERROR;
sl@0	1498	goto done;
sl@0	1499	}
sl@0	1500	}
sl@0	1501
sl@0	1502	if (compileScripts) {
sl@0	1503	/*
sl@0	1504	* Compile the else command body.
sl@0	1505	*/
sl@0	1506	#ifdef TCL_TIP280
sl@0	1507	envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
sl@0	1508	#endif
sl@0	1509	code = TclCompileCmdWord(interp, tokenPtr+1,
sl@0	1510	tokenPtr->numComponents, envPtr);
sl@0	1511	if (code != TCL_OK) {
sl@0	1512	if (code == TCL_ERROR) {
sl@0	1513	sprintf(buffer, "\n (\"if\" else script line %d)",
sl@0	1514	interp->errorLine);
sl@0	1515	Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0	1516	}
sl@0	1517	goto done;
sl@0	1518	}
sl@0	1519	}
sl@0	1520
sl@0	1521	/*
sl@0	1522	* Make sure there are no words after the else clause.
sl@0	1523	*/
sl@0	1524
sl@0	1525	wordIdx++;
sl@0	1526	if (wordIdx < numWords) {
sl@0	1527	Tcl_ResetResult(interp);
sl@0	1528	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	1529	"wrong # args: extra words after \"else\" clause in \"if\" command", -1);
sl@0	1530	code = TCL_ERROR;
sl@0	1531	goto done;
sl@0	1532	}
sl@0	1533	} else {
sl@0	1534	/*
sl@0	1535	* No else clause: the "if" command's result is an empty string.
sl@0	1536	*/
sl@0	1537
sl@0	1538	if (compileScripts) {
sl@0	1539	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0	1540	}
sl@0	1541	}
sl@0	1542
sl@0	1543	/*
sl@0	1544	* Fix the unconditional jumps to the end of the "if" command.
sl@0	1545	*/
sl@0	1546
sl@0	1547	for (j = jumpEndFixupArray.next; j > 0; j--) {
sl@0	1548	jumpIndex = (j - 1); /* i.e. process the closest jump first */
sl@0	1549	jumpDist = (envPtr->codeNext - envPtr->codeStart)
sl@0	1550	- jumpEndFixupArray.fixup[jumpIndex].codeOffset;
sl@0	1551	if (TclFixupForwardJump(envPtr,
sl@0	1552	&(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
sl@0	1553	/*
sl@0	1554	* Adjust the immediately preceeding "ifFalse" jump. We moved
sl@0	1555	* it's target (just after this jump) down three bytes.
sl@0	1556	*/
sl@0	1557
sl@0	1558	unsigned char *ifFalsePc = envPtr->codeStart
sl@0	1559	+ jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
sl@0	1560	unsigned char opCode = *ifFalsePc;
sl@0	1561	if (opCode == INST_JUMP_FALSE1) {
sl@0	1562	jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
sl@0	1563	jumpFalseDist += 3;
sl@0	1564	TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
sl@0	1565	} else if (opCode == INST_JUMP_FALSE4) {
sl@0	1566	jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
sl@0	1567	jumpFalseDist += 3;
sl@0	1568	TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
sl@0	1569	} else {
sl@0	1570	panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
sl@0	1571	}
sl@0	1572	}
sl@0	1573	}
sl@0	1574
sl@0	1575	/*
sl@0	1576	* Free the jumpFixupArray array if malloc'ed storage was used.
sl@0	1577	*/
sl@0	1578
sl@0	1579	done:
sl@0	1580	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	1581	TclFreeJumpFixupArray(&jumpFalseFixupArray);
sl@0	1582	TclFreeJumpFixupArray(&jumpEndFixupArray);
sl@0	1583	return code;
sl@0	1584	}
sl@0	1585
sl@0	1586	/*
sl@0	1587	*----------------------------------------------------------------------
sl@0	1588	*
sl@0	1589	* TclCompileIncrCmd --
sl@0	1590	*
sl@0	1591	* Procedure called to compile the "incr" command.
sl@0	1592	*
sl@0	1593	* Results:
sl@0	1594	* The return value is a standard Tcl result, which is TCL_OK if
sl@0	1595	* compilation was successful. If an error occurs then the
sl@0	1596	* interpreter's result contains a standard error message and TCL_ERROR
sl@0	1597	* is returned. If the command is too complex for TclCompileIncrCmd,
sl@0	1598	* TCL_OUT_LINE_COMPILE is returned indicating that the incr command
sl@0	1599	* should be compiled "out of line" by emitting code to invoke its
sl@0	1600	* command procedure at runtime.
sl@0	1601	*
sl@0	1602	* Side effects:
sl@0	1603	* Instructions are added to envPtr to execute the "incr" command
sl@0	1604	* at runtime.
sl@0	1605	*
sl@0	1606	*----------------------------------------------------------------------
sl@0	1607	*/
sl@0	1608
sl@0	1609	int
sl@0	1610	TclCompileIncrCmd(interp, parsePtr, envPtr)
sl@0	1611	Tcl_Interp interp; / Used for error reporting. */
sl@0	1612	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	1613	* command created by Tcl_ParseCommand. */
sl@0	1614	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	1615	{
sl@0	1616	Tcl_Token varTokenPtr, incrTokenPtr;
sl@0	1617	int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
sl@0	1618	int code = TCL_OK;
sl@0	1619
sl@0	1620	#ifdef TCL_TIP280
sl@0	1621	/* TIP #280 : Remember the per-word line information of the current
sl@0	1622	* command. An index is used instead of a pointer as recursive compilation
sl@0	1623	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	1624	* the nuloc now, it may change during the course of the function.
sl@0	1625	*/
sl@0	1626	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	1627	int eclIndex = mapPtr->nuloc - 1;
sl@0	1628	#endif
sl@0	1629
sl@0	1630	if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
sl@0	1631	Tcl_ResetResult(interp);
sl@0	1632	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	1633	"wrong # args: should be \"incr varName ?increment?\"", -1);
sl@0	1634	return TCL_ERROR;
sl@0	1635	}
sl@0	1636
sl@0	1637	varTokenPtr = parsePtr->tokenPtr
sl@0	1638	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	1639
sl@0	1640	code = TclPushVarName(interp, varTokenPtr, envPtr,
sl@0	1641	(TCL_NO_LARGE_INDEX \| TCL_CREATE_VAR),
sl@0	1642	#ifndef TCL_TIP280
sl@0	1643	&localIndex, &simpleVarName, &isScalar);
sl@0	1644	#else
sl@0	1645	&localIndex, &simpleVarName, &isScalar,
sl@0	1646	mapPtr->loc [eclIndex].line [1]);
sl@0	1647	#endif
sl@0	1648	if (code != TCL_OK) {
sl@0	1649	goto done;
sl@0	1650	}
sl@0	1651
sl@0	1652	/*
sl@0	1653	* If an increment is given, push it, but see first if it's a small
sl@0	1654	* integer.
sl@0	1655	*/
sl@0	1656
sl@0	1657	haveImmValue = 0;
sl@0	1658	immValue = 1;
sl@0	1659	if (parsePtr->numWords == 3) {
sl@0	1660	incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	1661	if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	1662	CONST char *word = incrTokenPtr[1].start;
sl@0	1663	int numBytes = incrTokenPtr[1].size;
sl@0	1664
sl@0	1665	/*
sl@0	1666	* Note there is a danger that modifying the string could have
sl@0	1667	* undesirable side effects. In this case, TclLooksLikeInt has
sl@0	1668	* no dependencies on shared strings so we should be safe.
sl@0	1669	*/
sl@0	1670
sl@0	1671	if (TclLooksLikeInt(word, numBytes)) {
sl@0	1672	int code;
sl@0	1673	Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
sl@0	1674	Tcl_IncrRefCount(intObj);
sl@0	1675	code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
sl@0	1676	Tcl_DecrRefCount(intObj);
sl@0	1677	if ((code == TCL_OK)
sl@0	1678	&& (-127 <= immValue) && (immValue <= 127)) {
sl@0	1679	haveImmValue = 1;
sl@0	1680	}
sl@0	1681	}
sl@0	1682	if (!haveImmValue) {
sl@0	1683	TclEmitPush(
sl@0	1684	TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
sl@0	1685	}
sl@0	1686	} else {
sl@0	1687	#ifdef TCL_TIP280
sl@0	1688	envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0	1689	#endif
sl@0	1690	code = TclCompileTokens(interp, incrTokenPtr+1,
sl@0	1691	incrTokenPtr->numComponents, envPtr);
sl@0	1692	if (code != TCL_OK) {
sl@0	1693	goto done;
sl@0	1694	}
sl@0	1695	}
sl@0	1696	} else { /* no incr amount given so use 1 */
sl@0	1697	haveImmValue = 1;
sl@0	1698	}
sl@0	1699
sl@0	1700	/*
sl@0	1701	* Emit the instruction to increment the variable.
sl@0	1702	*/
sl@0	1703
sl@0	1704	if (simpleVarName) {
sl@0	1705	if (isScalar) {
sl@0	1706	if (localIndex >= 0) {
sl@0	1707	if (haveImmValue) {
sl@0	1708	TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
sl@0	1709	TclEmitInt1(immValue, envPtr);
sl@0	1710	} else {
sl@0	1711	TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
sl@0	1712	}
sl@0	1713	} else {
sl@0	1714	if (haveImmValue) {
sl@0	1715	TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
sl@0	1716	} else {
sl@0	1717	TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
sl@0	1718	}
sl@0	1719	}
sl@0	1720	} else {
sl@0	1721	if (localIndex >= 0) {
sl@0	1722	if (haveImmValue) {
sl@0	1723	TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
sl@0	1724	TclEmitInt1(immValue, envPtr);
sl@0	1725	} else {
sl@0	1726	TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
sl@0	1727	}
sl@0	1728	} else {
sl@0	1729	if (haveImmValue) {
sl@0	1730	TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
sl@0	1731	} else {
sl@0	1732	TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
sl@0	1733	}
sl@0	1734	}
sl@0	1735	}
sl@0	1736	} else { /* non-simple variable name */
sl@0	1737	if (haveImmValue) {
sl@0	1738	TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
sl@0	1739	} else {
sl@0	1740	TclEmitOpcode(INST_INCR_STK, envPtr);
sl@0	1741	}
sl@0	1742	}
sl@0	1743
sl@0	1744	done:
sl@0	1745	return code;
sl@0	1746	}
sl@0	1747
sl@0	1748	/*
sl@0	1749	*----------------------------------------------------------------------
sl@0	1750	*
sl@0	1751	* TclCompileLappendCmd --
sl@0	1752	*
sl@0	1753	* Procedure called to compile the "lappend" command.
sl@0	1754	*
sl@0	1755	* Results:
sl@0	1756	* The return value is a standard Tcl result, which is normally TCL_OK
sl@0	1757	* unless there was an error while parsing string. If an error occurs
sl@0	1758	* then the interpreter's result contains a standard error message. If
sl@0	1759	* complation fails because the command requires a second level of
sl@0	1760	* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0	1761	* command should be compiled "out of line" by emitting code to
sl@0	1762	* invoke its command procedure (Tcl_LappendObjCmd) at runtime.
sl@0	1763	*
sl@0	1764	* Side effects:
sl@0	1765	* Instructions are added to envPtr to execute the "lappend" command
sl@0	1766	* at runtime.
sl@0	1767	*
sl@0	1768	*----------------------------------------------------------------------
sl@0	1769	*/
sl@0	1770
sl@0	1771	int
sl@0	1772	TclCompileLappendCmd(interp, parsePtr, envPtr)
sl@0	1773	Tcl_Interp interp; / Used for error reporting. */
sl@0	1774	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	1775	* command created by Tcl_ParseCommand. */
sl@0	1776	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	1777	{
sl@0	1778	Tcl_Token varTokenPtr, valueTokenPtr;
sl@0	1779	int simpleVarName, isScalar, localIndex, numWords;
sl@0	1780	int code = TCL_OK;
sl@0	1781
sl@0	1782	#ifdef TCL_TIP280
sl@0	1783	/* TIP #280 : Remember the per-word line information of the current
sl@0	1784	* command. An index is used instead of a pointer as recursive compilation
sl@0	1785	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	1786	* the nuloc now, it may change during the course of the function.
sl@0	1787	*/
sl@0	1788	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	1789	int eclIndex = mapPtr->nuloc - 1;
sl@0	1790	#endif
sl@0	1791
sl@0	1792	/*
sl@0	1793	* If we're not in a procedure, don't compile.
sl@0	1794	*/
sl@0	1795	if (envPtr->procPtr == NULL) {
sl@0	1796	return TCL_OUT_LINE_COMPILE;
sl@0	1797	}
sl@0	1798
sl@0	1799	numWords = parsePtr->numWords;
sl@0	1800	if (numWords == 1) {
sl@0	1801	Tcl_ResetResult(interp);
sl@0	1802	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	1803	"wrong # args: should be \"lappend varName ?value value ...?\"", -1);
sl@0	1804	return TCL_ERROR;
sl@0	1805	}
sl@0	1806	if (numWords != 3) {
sl@0	1807	/*
sl@0	1808	* LAPPEND instructions currently only handle one value appends
sl@0	1809	*/
sl@0	1810	return TCL_OUT_LINE_COMPILE;
sl@0	1811	}
sl@0	1812
sl@0	1813	/*
sl@0	1814	* Decide if we can use a frame slot for the var/array name or if we
sl@0	1815	* need to emit code to compute and push the name at runtime. We use a
sl@0	1816	* frame slot (entry in the array of local vars) if we are compiling a
sl@0	1817	* procedure body and if the name is simple text that does not include
sl@0	1818	* namespace qualifiers.
sl@0	1819	*/
sl@0	1820
sl@0	1821	varTokenPtr = parsePtr->tokenPtr
sl@0	1822	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	1823
sl@0	1824	code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
sl@0	1825	#ifndef TCL_TIP280
sl@0	1826	&localIndex, &simpleVarName, &isScalar);
sl@0	1827	#else
sl@0	1828	&localIndex, &simpleVarName, &isScalar,
sl@0	1829	mapPtr->loc [eclIndex].line [1]);
sl@0	1830	#endif
sl@0	1831	if (code != TCL_OK) {
sl@0	1832	goto done;
sl@0	1833	}
sl@0	1834
sl@0	1835	/*
sl@0	1836	* If we are doing an assignment, push the new value.
sl@0	1837	* In the no values case, create an empty object.
sl@0	1838	*/
sl@0	1839
sl@0	1840	if (numWords > 2) {
sl@0	1841	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	1842	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	1843	TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0	1844	valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
sl@0	1845	} else {
sl@0	1846	#ifdef TCL_TIP280
sl@0	1847	envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0	1848	#endif
sl@0	1849	code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0	1850	valueTokenPtr->numComponents, envPtr);
sl@0	1851	if (code != TCL_OK) {
sl@0	1852	goto done;
sl@0	1853	}
sl@0	1854	}
sl@0	1855	}
sl@0	1856
sl@0	1857	/*
sl@0	1858	* Emit instructions to set/get the variable.
sl@0	1859	*/
sl@0	1860
sl@0	1861	/*
sl@0	1862	* The *_STK opcodes should be refactored to make better use of existing
sl@0	1863	* LOAD/STORE instructions.
sl@0	1864	*/
sl@0	1865	if (simpleVarName) {
sl@0	1866	if (isScalar) {
sl@0	1867	if (localIndex >= 0) {
sl@0	1868	if (localIndex <= 255) {
sl@0	1869	TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
sl@0	1870	} else {
sl@0	1871	TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
sl@0	1872	}
sl@0	1873	} else {
sl@0	1874	TclEmitOpcode(INST_LAPPEND_STK, envPtr);
sl@0	1875	}
sl@0	1876	} else {
sl@0	1877	if (localIndex >= 0) {
sl@0	1878	if (localIndex <= 255) {
sl@0	1879	TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
sl@0	1880	} else {
sl@0	1881	TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
sl@0	1882	}
sl@0	1883	} else {
sl@0	1884	TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
sl@0	1885	}
sl@0	1886	}
sl@0	1887	} else {
sl@0	1888	TclEmitOpcode(INST_LAPPEND_STK, envPtr);
sl@0	1889	}
sl@0	1890
sl@0	1891	done:
sl@0	1892	return code;
sl@0	1893	}
sl@0	1894
sl@0	1895	/*
sl@0	1896	*----------------------------------------------------------------------
sl@0	1897	*
sl@0	1898	* TclCompileLindexCmd --
sl@0	1899	*
sl@0	1900	* Procedure called to compile the "lindex" command.
sl@0	1901	*
sl@0	1902	* Results:
sl@0	1903	* The return value is a standard Tcl result, which is TCL_OK if the
sl@0	1904	* compilation was successful. If the command cannot be byte-compiled,
sl@0	1905	* TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
sl@0	1906	* interpreter's result contains an error message, and TCL_ERROR is
sl@0	1907	* returned.
sl@0	1908	*
sl@0	1909	* Side effects:
sl@0	1910	* Instructions are added to envPtr to execute the "lindex" command
sl@0	1911	* at runtime.
sl@0	1912	*
sl@0	1913	*----------------------------------------------------------------------
sl@0	1914	*/
sl@0	1915
sl@0	1916	int
sl@0	1917	TclCompileLindexCmd(interp, parsePtr, envPtr)
sl@0	1918	Tcl_Interp interp; / Used for error reporting. */
sl@0	1919	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	1920	* command created by Tcl_ParseCommand. */
sl@0	1921	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	1922	{
sl@0	1923	Tcl_Token *varTokenPtr;
sl@0	1924	int code, i;
sl@0	1925
sl@0	1926	#ifdef TCL_TIP280
sl@0	1927	/* TIP #280 : Remember the per-word line information of the current
sl@0	1928	* command. An index is used instead of a pointer as recursive compilation
sl@0	1929	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	1930	* the nuloc now, it may change during the course of the function.
sl@0	1931	*/
sl@0	1932	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	1933	int eclIndex = mapPtr->nuloc - 1;
sl@0	1934	#endif
sl@0	1935
sl@0	1936	int numWords;
sl@0	1937	numWords = parsePtr->numWords;
sl@0	1938
sl@0	1939	/*
sl@0	1940	* Quit if too few args
sl@0	1941	*/
sl@0	1942
sl@0	1943	if ( numWords <= 1 ) {
sl@0	1944	return TCL_OUT_LINE_COMPILE;
sl@0	1945	}
sl@0	1946
sl@0	1947	varTokenPtr = parsePtr->tokenPtr
sl@0	1948	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	1949
sl@0	1950	/*
sl@0	1951	* Push the operands onto the stack.
sl@0	1952	*/
sl@0	1953
sl@0	1954	for ( i = 1 ; i < numWords ; i++ ) {
sl@0	1955	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	1956	TclEmitPush(
sl@0	1957	TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
sl@0	1958	varTokenPtr[1].size), envPtr);
sl@0	1959	} else {
sl@0	1960	#ifdef TCL_TIP280
sl@0	1961	envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0	1962	#endif
sl@0	1963	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	1964	varTokenPtr->numComponents, envPtr);
sl@0	1965	if (code != TCL_OK) {
sl@0	1966	return code;
sl@0	1967	}
sl@0	1968	}
sl@0	1969	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	1970	}
sl@0	1971
sl@0	1972	/*
sl@0	1973	* Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
sl@0	1974	* if there are multiple index args.
sl@0	1975	*/
sl@0	1976
sl@0	1977	if ( numWords == 3 ) {
sl@0	1978	TclEmitOpcode( INST_LIST_INDEX, envPtr );
sl@0	1979	} else {
sl@0	1980	TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
sl@0	1981	}
sl@0	1982
sl@0	1983	return TCL_OK;
sl@0	1984	}
sl@0	1985
sl@0	1986	/*
sl@0	1987	*----------------------------------------------------------------------
sl@0	1988	*
sl@0	1989	* TclCompileListCmd --
sl@0	1990	*
sl@0	1991	* Procedure called to compile the "list" command.
sl@0	1992	*
sl@0	1993	* Results:
sl@0	1994	* The return value is a standard Tcl result, which is normally TCL_OK
sl@0	1995	* unless there was an error while parsing string. If an error occurs
sl@0	1996	* then the interpreter's result contains a standard error message. If
sl@0	1997	* complation fails because the command requires a second level of
sl@0	1998	* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0	1999	* command should be compiled "out of line" by emitting code to
sl@0	2000	* invoke its command procedure (Tcl_ListObjCmd) at runtime.
sl@0	2001	*
sl@0	2002	* Side effects:
sl@0	2003	* Instructions are added to envPtr to execute the "list" command
sl@0	2004	* at runtime.
sl@0	2005	*
sl@0	2006	*----------------------------------------------------------------------
sl@0	2007	*/
sl@0	2008
sl@0	2009	int
sl@0	2010	TclCompileListCmd(interp, parsePtr, envPtr)
sl@0	2011	Tcl_Interp interp; / Used for error reporting. */
sl@0	2012	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	2013	* command created by Tcl_ParseCommand. */
sl@0	2014	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	2015	{
sl@0	2016	#ifdef TCL_TIP280
sl@0	2017	/* TIP #280 : Remember the per-word line information of the current
sl@0	2018	* command. An index is used instead of a pointer as recursive compilation
sl@0	2019	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	2020	* the nuloc now, it may change during the course of the function.
sl@0	2021	*/
sl@0	2022	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	2023	int eclIndex = mapPtr->nuloc - 1;
sl@0	2024	#endif
sl@0	2025
sl@0	2026	/*
sl@0	2027	* If we're not in a procedure, don't compile.
sl@0	2028	*/
sl@0	2029	if (envPtr->procPtr == NULL) {
sl@0	2030	return TCL_OUT_LINE_COMPILE;
sl@0	2031	}
sl@0	2032
sl@0	2033	if (parsePtr->numWords == 1) {
sl@0	2034	/*
sl@0	2035	* Empty args case
sl@0	2036	*/
sl@0	2037
sl@0	2038	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0	2039	} else {
sl@0	2040	/*
sl@0	2041	* Push the all values onto the stack.
sl@0	2042	*/
sl@0	2043	Tcl_Token *valueTokenPtr;
sl@0	2044	int i, code, numWords;
sl@0	2045
sl@0	2046	numWords = parsePtr->numWords;
sl@0	2047
sl@0	2048	valueTokenPtr = parsePtr->tokenPtr
sl@0	2049	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	2050	for (i = 1; i < numWords; i++) {
sl@0	2051	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2052	TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0	2053	valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
sl@0	2054	} else {
sl@0	2055	#ifdef TCL_TIP280
sl@0	2056	envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0	2057	#endif
sl@0	2058	code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0	2059	valueTokenPtr->numComponents, envPtr);
sl@0	2060	if (code != TCL_OK) {
sl@0	2061	return code;
sl@0	2062	}
sl@0	2063	}
sl@0	2064	valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
sl@0	2065	}
sl@0	2066	TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
sl@0	2067	}
sl@0	2068
sl@0	2069	return TCL_OK;
sl@0	2070	}
sl@0	2071
sl@0	2072	/*
sl@0	2073	*----------------------------------------------------------------------
sl@0	2074	*
sl@0	2075	* TclCompileLlengthCmd --
sl@0	2076	*
sl@0	2077	* Procedure called to compile the "llength" command.
sl@0	2078	*
sl@0	2079	* Results:
sl@0	2080	* The return value is a standard Tcl result, which is TCL_OK if the
sl@0	2081	* compilation was successful. If the command cannot be byte-compiled,
sl@0	2082	* TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
sl@0	2083	* interpreter's result contains an error message, and TCL_ERROR is
sl@0	2084	* returned.
sl@0	2085	*
sl@0	2086	* Side effects:
sl@0	2087	* Instructions are added to envPtr to execute the "llength" command
sl@0	2088	* at runtime.
sl@0	2089	*
sl@0	2090	*----------------------------------------------------------------------
sl@0	2091	*/
sl@0	2092
sl@0	2093	int
sl@0	2094	TclCompileLlengthCmd(interp, parsePtr, envPtr)
sl@0	2095	Tcl_Interp interp; / Used for error reporting. */
sl@0	2096	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	2097	* command created by Tcl_ParseCommand. */
sl@0	2098	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	2099	{
sl@0	2100	Tcl_Token *varTokenPtr;
sl@0	2101	int code;
sl@0	2102
sl@0	2103	#ifdef TCL_TIP280
sl@0	2104	/* TIP #280 : Remember the per-word line information of the current
sl@0	2105	* command. An index is used instead of a pointer as recursive compilation
sl@0	2106	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	2107	* the nuloc now, it may change during the course of the function.
sl@0	2108	*/
sl@0	2109	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	2110	int eclIndex = mapPtr->nuloc - 1;
sl@0	2111	#endif
sl@0	2112
sl@0	2113	if (parsePtr->numWords != 2) {
sl@0	2114	Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
sl@0	2115	TCL_STATIC);
sl@0	2116	return TCL_ERROR;
sl@0	2117	}
sl@0	2118	varTokenPtr = parsePtr->tokenPtr
sl@0	2119	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	2120
sl@0	2121	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2122	/*
sl@0	2123	* We could simply count the number of elements here and push
sl@0	2124	* that value, but that is too rare a case to waste the code space.
sl@0	2125	*/
sl@0	2126	TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
sl@0	2127	varTokenPtr[1].size), envPtr);
sl@0	2128	} else {
sl@0	2129	#ifdef TCL_TIP280
sl@0	2130	envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0	2131	#endif
sl@0	2132	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	2133	varTokenPtr->numComponents, envPtr);
sl@0	2134	if (code != TCL_OK) {
sl@0	2135	return code;
sl@0	2136	}
sl@0	2137	}
sl@0	2138	TclEmitOpcode(INST_LIST_LENGTH, envPtr);
sl@0	2139	return TCL_OK;
sl@0	2140	}
sl@0	2141
sl@0	2142	/*
sl@0	2143	*----------------------------------------------------------------------
sl@0	2144	*
sl@0	2145	* TclCompileLsetCmd --
sl@0	2146	*
sl@0	2147	* Procedure called to compile the "lset" command.
sl@0	2148	*
sl@0	2149	* Results:
sl@0	2150	* The return value is a standard Tcl result, which is TCL_OK if
sl@0	2151	* the compilation was successful. If the "lset" command is too
sl@0	2152	* complex for this function, then TCL_OUT_LINE_COMPILE is returned,
sl@0	2153	* indicating that the command should be compiled "out of line"
sl@0	2154	* (that is, not byte-compiled). If an error occurs, TCL_ERROR is
sl@0	2155	* returned, and the interpreter result contains an error message.
sl@0	2156	*
sl@0	2157	* Side effects:
sl@0	2158	* Instructions are added to envPtr to execute the "lset" command
sl@0	2159	* at runtime.
sl@0	2160	*
sl@0	2161	* The general template for execution of the "lset" command is:
sl@0	2162	* (1) Instructions to push the variable name, unless the
sl@0	2163	* variable is local to the stack frame.
sl@0	2164	* (2) If the variable is an array element, instructions
sl@0	2165	* to push the array element name.
sl@0	2166	* (3) Instructions to push each of zero or more "index" arguments
sl@0	2167	* to the stack, followed with the "newValue" element.
sl@0	2168	* (4) Instructions to duplicate the variable name and/or array
sl@0	2169	* element name onto the top of the stack, if either was
sl@0	2170	* pushed at steps (1) and (2).
sl@0	2171	* (5) The appropriate INST_LOAD_* instruction to place the
sl@0	2172	* original value of the list variable at top of stack.
sl@0	2173	* (6) At this point, the stack contains:
sl@0	2174	* varName? arrayElementName? index1 index2 ... newValue oldList
sl@0	2175	* The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
sl@0	2176	* according as whether there is exactly one index element (LIST)
sl@0	2177	* or either zero or else two or more (FLAT). This instruction
sl@0	2178	* removes everything from the stack except for the two names
sl@0	2179	* and pushes the new value of the variable.
sl@0	2180	* (7) Finally, INST_STORE_* stores the new value in the variable
sl@0	2181	* and cleans up the stack.
sl@0	2182	*
sl@0	2183	*----------------------------------------------------------------------
sl@0	2184	*/
sl@0	2185
sl@0	2186	int
sl@0	2187	TclCompileLsetCmd( interp, parsePtr, envPtr )
sl@0	2188	Tcl_Interp* interp; /* Tcl interpreter for error reporting */
sl@0	2189	Tcl_Parse* parsePtr; /* Points to a parse structure for
sl@0	2190	* the command */
sl@0	2191	CompileEnv* envPtr; /* Holds the resulting instructions */
sl@0	2192	{
sl@0	2193
sl@0	2194	int tempDepth; /* Depth used for emitting one part
sl@0	2195	* of the code burst. */
sl@0	2196	Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing
sl@0	2197	* the parse of the variable name */
sl@0	2198
sl@0	2199	int result; /* Status return from library calls */
sl@0	2200
sl@0	2201	int localIndex; /* Index of var in local var table */
sl@0	2202	int simpleVarName; /* Flag == 1 if var name is simple */
sl@0	2203	int isScalar; /* Flag == 1 if scalar, 0 if array */
sl@0	2204
sl@0	2205	int i;
sl@0	2206
sl@0	2207	#ifdef TCL_TIP280
sl@0	2208	/* TIP #280 : Remember the per-word line information of the current
sl@0	2209	* command. An index is used instead of a pointer as recursive compilation
sl@0	2210	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	2211	* the nuloc now, it may change during the course of the function.
sl@0	2212	*/
sl@0	2213	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	2214	int eclIndex = mapPtr->nuloc - 1;
sl@0	2215	#endif
sl@0	2216
sl@0	2217	/* Check argument count */
sl@0	2218
sl@0	2219	if ( parsePtr->numWords < 3 ) {
sl@0	2220	/* Fail at run time, not in compilation */
sl@0	2221	return TCL_OUT_LINE_COMPILE;
sl@0	2222	}
sl@0	2223
sl@0	2224	/*
sl@0	2225	* Decide if we can use a frame slot for the var/array name or if we
sl@0	2226	* need to emit code to compute and push the name at runtime. We use a
sl@0	2227	* frame slot (entry in the array of local vars) if we are compiling a
sl@0	2228	* procedure body and if the name is simple text that does not include
sl@0	2229	* namespace qualifiers.
sl@0	2230	*/
sl@0	2231
sl@0	2232	varTokenPtr = parsePtr->tokenPtr
sl@0	2233	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	2234	result = TclPushVarName( interp, varTokenPtr, envPtr,
sl@0	2235	#ifndef TCL_TIP280
sl@0	2236	TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
sl@0	2237	#else
sl@0	2238	TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar,
sl@0	2239	mapPtr->loc [eclIndex].line [1]);
sl@0	2240	#endif
sl@0	2241	if (result != TCL_OK) {
sl@0	2242	return result;
sl@0	2243	}
sl@0	2244
sl@0	2245	/* Push the "index" args and the new element value. */
sl@0	2246
sl@0	2247	for ( i = 2; i < parsePtr->numWords; ++i ) {
sl@0	2248
sl@0	2249	/* Advance to next arg */
sl@0	2250
sl@0	2251	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	2252
sl@0	2253	/* Push an arg */
sl@0	2254
sl@0	2255	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2256	TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
sl@0	2257	varTokenPtr[1].size), envPtr);
sl@0	2258	} else {
sl@0	2259	#ifdef TCL_TIP280
sl@0	2260	envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0	2261	#endif
sl@0	2262	result = TclCompileTokens(interp, varTokenPtr+1,
sl@0	2263	varTokenPtr->numComponents, envPtr);
sl@0	2264	if ( result != TCL_OK ) {
sl@0	2265	return result;
sl@0	2266	}
sl@0	2267	}
sl@0	2268	}
sl@0	2269
sl@0	2270	/*
sl@0	2271	* Duplicate the variable name if it's been pushed.
sl@0	2272	*/
sl@0	2273
sl@0	2274	if ( !simpleVarName \|\| localIndex < 0 ) {
sl@0	2275	if ( !simpleVarName \|\| isScalar ) {
sl@0	2276	tempDepth = parsePtr->numWords - 2;
sl@0	2277	} else {
sl@0	2278	tempDepth = parsePtr->numWords - 1;
sl@0	2279	}
sl@0	2280	TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
sl@0	2281	}
sl@0	2282
sl@0	2283	/*
sl@0	2284	* Duplicate an array index if one's been pushed
sl@0	2285	*/
sl@0	2286
sl@0	2287	if ( simpleVarName && !isScalar ) {
sl@0	2288	if ( localIndex < 0 ) {
sl@0	2289	tempDepth = parsePtr->numWords - 1;
sl@0	2290	} else {
sl@0	2291	tempDepth = parsePtr->numWords - 2;
sl@0	2292	}
sl@0	2293	TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
sl@0	2294	}
sl@0	2295
sl@0	2296	/*
sl@0	2297	* Emit code to load the variable's value.
sl@0	2298	*/
sl@0	2299
sl@0	2300	if ( !simpleVarName ) {
sl@0	2301	TclEmitOpcode( INST_LOAD_STK, envPtr );
sl@0	2302	} else if ( isScalar ) {
sl@0	2303	if ( localIndex < 0 ) {
sl@0	2304	TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
sl@0	2305	} else if ( localIndex < 0x100 ) {
sl@0	2306	TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
sl@0	2307	} else {
sl@0	2308	TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
sl@0	2309	}
sl@0	2310	} else {
sl@0	2311	if ( localIndex < 0 ) {
sl@0	2312	TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
sl@0	2313	} else if ( localIndex < 0x100 ) {
sl@0	2314	TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
sl@0	2315	} else {
sl@0	2316	TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
sl@0	2317	}
sl@0	2318	}
sl@0	2319
sl@0	2320	/*
sl@0	2321	* Emit the correct variety of 'lset' instruction
sl@0	2322	*/
sl@0	2323
sl@0	2324	if ( parsePtr->numWords == 4 ) {
sl@0	2325	TclEmitOpcode( INST_LSET_LIST, envPtr );
sl@0	2326	} else {
sl@0	2327	TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
sl@0	2328	}
sl@0	2329
sl@0	2330	/*
sl@0	2331	* Emit code to put the value back in the variable
sl@0	2332	*/
sl@0	2333
sl@0	2334	if ( !simpleVarName ) {
sl@0	2335	TclEmitOpcode( INST_STORE_STK, envPtr );
sl@0	2336	} else if ( isScalar ) {
sl@0	2337	if ( localIndex < 0 ) {
sl@0	2338	TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
sl@0	2339	} else if ( localIndex < 0x100 ) {
sl@0	2340	TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
sl@0	2341	} else {
sl@0	2342	TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
sl@0	2343	}
sl@0	2344	} else {
sl@0	2345	if ( localIndex < 0 ) {
sl@0	2346	TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
sl@0	2347	} else if ( localIndex < 0x100 ) {
sl@0	2348	TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
sl@0	2349	} else {
sl@0	2350	TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
sl@0	2351	}
sl@0	2352	}
sl@0	2353
sl@0	2354	return TCL_OK;
sl@0	2355
sl@0	2356	}
sl@0	2357
sl@0	2358	/*
sl@0	2359	*----------------------------------------------------------------------
sl@0	2360	*
sl@0	2361	* TclCompileRegexpCmd --
sl@0	2362	*
sl@0	2363	* Procedure called to compile the "regexp" command.
sl@0	2364	*
sl@0	2365	* Results:
sl@0	2366	* The return value is a standard Tcl result, which is TCL_OK if
sl@0	2367	* the compilation was successful. If the "regexp" command is too
sl@0	2368	* complex for this function, then TCL_OUT_LINE_COMPILE is returned,
sl@0	2369	* indicating that the command should be compiled "out of line"
sl@0	2370	* (that is, not byte-compiled). If an error occurs, TCL_ERROR is
sl@0	2371	* returned, and the interpreter result contains an error message.
sl@0	2372	*
sl@0	2373	* Side effects:
sl@0	2374	* Instructions are added to envPtr to execute the "regexp" command
sl@0	2375	* at runtime.
sl@0	2376	*
sl@0	2377	*----------------------------------------------------------------------
sl@0	2378	*/
sl@0	2379
sl@0	2380	int
sl@0	2381	TclCompileRegexpCmd(interp, parsePtr, envPtr)
sl@0	2382	Tcl_Interp* interp; /* Tcl interpreter for error reporting */
sl@0	2383	Tcl_Parse* parsePtr; /* Points to a parse structure for
sl@0	2384	* the command */
sl@0	2385	CompileEnv* envPtr; /* Holds the resulting instructions */
sl@0	2386	{
sl@0	2387	Tcl_Token varTokenPtr; / Pointer to the Tcl_Token representing
sl@0	2388	* the parse of the RE or string */
sl@0	2389	int i, len, code, nocase, anchorLeft, anchorRight, start;
sl@0	2390	char *str;
sl@0	2391
sl@0	2392	#ifdef TCL_TIP280
sl@0	2393	/* TIP #280 : Remember the per-word line information of the current
sl@0	2394	* command. An index is used instead of a pointer as recursive compilation
sl@0	2395	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	2396	* the nuloc now, it may change during the course of the function.
sl@0	2397	*/
sl@0	2398	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	2399	int eclIndex = mapPtr->nuloc - 1;
sl@0	2400	#endif
sl@0	2401
sl@0	2402	/*
sl@0	2403	* We are only interested in compiling simple regexp cases.
sl@0	2404	* Currently supported compile cases are:
sl@0	2405	* regexp ?-nocase? ?--? staticString $var
sl@0	2406	* regexp ?-nocase? ?--? {^staticString$} $var
sl@0	2407	*/
sl@0	2408	if (parsePtr->numWords < 3) {
sl@0	2409	return TCL_OUT_LINE_COMPILE;
sl@0	2410	}
sl@0	2411
sl@0	2412	nocase = 0;
sl@0	2413	varTokenPtr = parsePtr->tokenPtr;
sl@0	2414
sl@0	2415	/*
sl@0	2416	* We only look for -nocase and -- as options. Everything else
sl@0	2417	* gets pushed to runtime execution. This is different than regexp's
sl@0	2418	* runtime option handling, but satisfies our stricter needs.
sl@0	2419	*/
sl@0	2420	for (i = 1; i < parsePtr->numWords - 2; i++) {
sl@0	2421	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	2422	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0	2423	/* Not a simple string - punt to runtime. */
sl@0	2424	return TCL_OUT_LINE_COMPILE;
sl@0	2425	}
sl@0	2426	str = (char *) varTokenPtr[1].start;
sl@0	2427	len = varTokenPtr[1].size;
sl@0	2428	if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
sl@0	2429	i++;
sl@0	2430	break;
sl@0	2431	} else if ((len > 1)
sl@0	2432	&& (strncmp(str, "-nocase", (unsigned) len) == 0)) {
sl@0	2433	nocase = 1;
sl@0	2434	} else {
sl@0	2435	/* Not an option we recognize. */
sl@0	2436	return TCL_OUT_LINE_COMPILE;
sl@0	2437	}
sl@0	2438	}
sl@0	2439
sl@0	2440	if ((parsePtr->numWords - i) != 2) {
sl@0	2441	/* We don't support capturing to variables */
sl@0	2442	return TCL_OUT_LINE_COMPILE;
sl@0	2443	}
sl@0	2444
sl@0	2445	/*
sl@0	2446	* Get the regexp string. If it is not a simple string, punt to runtime.
sl@0	2447	* If it has a '-', it could be an incorrectly formed regexp command.
sl@0	2448	*/
sl@0	2449	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	2450	str = (char *) varTokenPtr[1].start;
sl@0	2451	len = varTokenPtr[1].size;
sl@0	2452	if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) \|\| (*str == '-')) {
sl@0	2453	return TCL_OUT_LINE_COMPILE;
sl@0	2454	}
sl@0	2455
sl@0	2456	if (len == 0) {
sl@0	2457	/*
sl@0	2458	* The semantics of regexp are always match on re == "".
sl@0	2459	*/
sl@0	2460	TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
sl@0	2461	return TCL_OK;
sl@0	2462	}
sl@0	2463
sl@0	2464	/*
sl@0	2465	* Make a copy of the string that is null-terminated for checks which
sl@0	2466	* require such.
sl@0	2467	*/
sl@0	2468	str = (char *) ckalloc((unsigned) len + 1);
sl@0	2469	strncpy(str, varTokenPtr[1].start, (size_t) len);
sl@0	2470	str[len] = '\0';
sl@0	2471	start = 0;
sl@0	2472
sl@0	2473	/*
sl@0	2474	* Check for anchored REs (ie ^foo$), so we can use string equal if
sl@0	2475	* possible. Do not alter the start of str so we can free it correctly.
sl@0	2476	*/
sl@0	2477	if (str[0] == '^') {
sl@0	2478	start++;
sl@0	2479	anchorLeft = 1;
sl@0	2480	} else {
sl@0	2481	anchorLeft = 0;
sl@0	2482	}
sl@0	2483	if ((str[len-1] == '$') && ((len == 1) \|\| (str[len-2] != '\\'))) {
sl@0	2484	anchorRight = 1;
sl@0	2485	str[--len] = '\0';
sl@0	2486	} else {
sl@0	2487	anchorRight = 0;
sl@0	2488	}
sl@0	2489
sl@0	2490	/*
sl@0	2491	* On the first (pattern) arg, check to see if any RE special characters
sl@0	2492	* are in the word. If not, this is the same as 'string equal'.
sl@0	2493	*/
sl@0	2494	if ((len > (1+start)) && (str[start] == '.') && (str[start+1] == '*')) {
sl@0	2495	start += 2;
sl@0	2496	anchorLeft = 0;
sl@0	2497	}
sl@0	2498	if ((len > (2+start)) && (str[len-3] != '\\')
sl@0	2499	&& (str[len-2] == '.') && (str[len-1] == '*')) {
sl@0	2500	len -= 2;
sl@0	2501	str[len] = '\0';
sl@0	2502	anchorRight = 0;
sl@0	2503	}
sl@0	2504
sl@0	2505	/*
sl@0	2506	* Don't do anything with REs with other special chars. Also check if
sl@0	2507	* this is a bad RE (do this at the end because it can be expensive).
sl@0	2508	* If so, let it complain at runtime.
sl@0	2509	*/
sl@0	2510	if ((strpbrk(str + start, "*+?{}()[].\\\|^$") != NULL)
sl@0	2511	\|\| (Tcl_RegExpCompile(NULL, str) == NULL)) {
sl@0	2512	ckfree((char *) str);
sl@0	2513	return TCL_OUT_LINE_COMPILE;
sl@0	2514	}
sl@0	2515
sl@0	2516	if (anchorLeft && anchorRight) {
sl@0	2517	TclEmitPush(TclRegisterNewLiteral(envPtr, str+start, len-start),
sl@0	2518	envPtr);
sl@0	2519	} else {
sl@0	2520	/*
sl@0	2521	* This needs to find the substring anywhere in the string, so
sl@0	2522	* use string match and foo, with appropriate anchoring.
sl@0	2523	*/
sl@0	2524	char *newStr = ckalloc((unsigned) len + 3);
sl@0	2525	len -= start;
sl@0	2526	if (anchorLeft) {
sl@0	2527	strncpy(newStr, str + start, (size_t) len);
sl@0	2528	} else {
sl@0	2529	newStr[0] = '*';
sl@0	2530	strncpy(newStr + 1, str + start, (size_t) len++);
sl@0	2531	}
sl@0	2532	if (!anchorRight) {
sl@0	2533	newStr[len++] = '*';
sl@0	2534	}
sl@0	2535	newStr[len] = '\0';
sl@0	2536	TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len), envPtr);
sl@0	2537	ckfree((char *) newStr);
sl@0	2538	}
sl@0	2539	ckfree((char *) str);
sl@0	2540
sl@0	2541	/*
sl@0	2542	* Push the string arg
sl@0	2543	*/
sl@0	2544	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	2545	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2546	TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0	2547	varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
sl@0	2548	} else {
sl@0	2549	#ifdef TCL_TIP280
sl@0	2550	envPtr->line = mapPtr->loc [eclIndex].line [parsePtr->numWords-1];
sl@0	2551	#endif
sl@0	2552	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	2553	varTokenPtr->numComponents, envPtr);
sl@0	2554	if (code != TCL_OK) {
sl@0	2555	return code;
sl@0	2556	}
sl@0	2557	}
sl@0	2558
sl@0	2559	if (anchorLeft && anchorRight && !nocase) {
sl@0	2560	TclEmitOpcode(INST_STR_EQ, envPtr);
sl@0	2561	} else {
sl@0	2562	TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
sl@0	2563	}
sl@0	2564
sl@0	2565	return TCL_OK;
sl@0	2566	}
sl@0	2567
sl@0	2568	/*
sl@0	2569	*----------------------------------------------------------------------
sl@0	2570	*
sl@0	2571	* TclCompileReturnCmd --
sl@0	2572	*
sl@0	2573	* Procedure called to compile the "return" command.
sl@0	2574	*
sl@0	2575	* Results:
sl@0	2576	* The return value is a standard Tcl result, which is TCL_OK if the
sl@0	2577	* compilation was successful. If the particular return command is
sl@0	2578	* too complex for this function (ie, return with any flags like "-code"
sl@0	2579	* or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
sl@0	2580	* the command should be compiled "out of line" (eg, not byte compiled).
sl@0	2581	* If an error occurs then the interpreter's result contains a standard
sl@0	2582	* error message.
sl@0	2583	*
sl@0	2584	* Side effects:
sl@0	2585	* Instructions are added to envPtr to execute the "return" command
sl@0	2586	* at runtime.
sl@0	2587	*
sl@0	2588	*----------------------------------------------------------------------
sl@0	2589	*/
sl@0	2590
sl@0	2591	int
sl@0	2592	TclCompileReturnCmd(interp, parsePtr, envPtr)
sl@0	2593	Tcl_Interp interp; / Used for error reporting. */
sl@0	2594	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	2595	* command created by Tcl_ParseCommand. */
sl@0	2596	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	2597	{
sl@0	2598	Tcl_Token *varTokenPtr;
sl@0	2599	int code;
sl@0	2600	int index = envPtr->exceptArrayNext - 1;
sl@0	2601
sl@0	2602	#ifdef TCL_TIP280
sl@0	2603	/* TIP #280 : Remember the per-word line information of the current
sl@0	2604	* command. An index is used instead of a pointer as recursive compilation
sl@0	2605	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	2606	* the nuloc now, it may change during the course of the function.
sl@0	2607	*/
sl@0	2608	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	2609	int eclIndex = mapPtr->nuloc - 1;
sl@0	2610	#endif
sl@0	2611
sl@0	2612	/*
sl@0	2613	* If we're not in a procedure, don't compile.
sl@0	2614	*/
sl@0	2615
sl@0	2616	if (envPtr->procPtr == NULL) {
sl@0	2617	return TCL_OUT_LINE_COMPILE;
sl@0	2618	}
sl@0	2619
sl@0	2620	/*
sl@0	2621	* Look back through the ExceptionRanges of the current CompileEnv,
sl@0	2622	* from exceptArrayPtr[(exceptArrayNext - 1)] down to
sl@0	2623	* exceptArrayPtr[0] to see if any of them is an enclosing [catch].
sl@0	2624	* If there's an enclosing [catch], don't compile.
sl@0	2625	*/
sl@0	2626
sl@0	2627	while (index >= 0) {
sl@0	2628	ExceptionRange range = envPtr->exceptArrayPtr[index];
sl@0	2629	if ((range.type == CATCH_EXCEPTION_RANGE)
sl@0	2630	&& (range.catchOffset == -1)) {
sl@0	2631	return TCL_OUT_LINE_COMPILE;
sl@0	2632	}
sl@0	2633	index--;
sl@0	2634	}
sl@0	2635
sl@0	2636	switch (parsePtr->numWords) {
sl@0	2637	case 1: {
sl@0	2638	/*
sl@0	2639	* Simple case: [return]
sl@0	2640	* Just push the literal string "".
sl@0	2641	*/
sl@0	2642	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0	2643	break;
sl@0	2644	}
sl@0	2645	case 2: {
sl@0	2646	/*
sl@0	2647	* More complex cases:
sl@0	2648	* [return "foo"]
sl@0	2649	* [return $value]
sl@0	2650	* [return [otherCmd]]
sl@0	2651	*/
sl@0	2652	varTokenPtr = parsePtr->tokenPtr
sl@0	2653	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	2654	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2655	/*
sl@0	2656	* [return "foo"] case: the parse token is a simple word,
sl@0	2657	* so just push it.
sl@0	2658	*/
sl@0	2659	TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
sl@0	2660	varTokenPtr[1].size), envPtr);
sl@0	2661	} else {
sl@0	2662	/*
sl@0	2663	* Parse token is more complex, so compile it; this handles the
sl@0	2664	* variable reference and nested command cases. If the
sl@0	2665	* parse token can be byte-compiled, then this instance of
sl@0	2666	* "return" will be byte-compiled; otherwise it will be
sl@0	2667	* out line compiled.
sl@0	2668	*/
sl@0	2669	#ifdef TCL_TIP280
sl@0	2670	envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0	2671	#endif
sl@0	2672	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	2673	varTokenPtr->numComponents, envPtr);
sl@0	2674	if (code != TCL_OK) {
sl@0	2675	return code;
sl@0	2676	}
sl@0	2677	}
sl@0	2678	break;
sl@0	2679	}
sl@0	2680	default: {
sl@0	2681	/*
sl@0	2682	* Most complex return cases: everything else, including
sl@0	2683	* [return -code error], etc.
sl@0	2684	*/
sl@0	2685	return TCL_OUT_LINE_COMPILE;
sl@0	2686	}
sl@0	2687	}
sl@0	2688
sl@0	2689	/*
sl@0	2690	* The INST_DONE opcode actually causes the branching out of the
sl@0	2691	* subroutine, and takes the top stack item as the return result
sl@0	2692	* (which is why we pushed the value above).
sl@0	2693	*/
sl@0	2694	TclEmitOpcode(INST_DONE, envPtr);
sl@0	2695	return TCL_OK;
sl@0	2696	}
sl@0	2697
sl@0	2698	/*
sl@0	2699	*----------------------------------------------------------------------
sl@0	2700	*
sl@0	2701	* TclCompileSetCmd --
sl@0	2702	*
sl@0	2703	* Procedure called to compile the "set" command.
sl@0	2704	*
sl@0	2705	* Results:
sl@0	2706	* The return value is a standard Tcl result, which is normally TCL_OK
sl@0	2707	* unless there was an error while parsing string. If an error occurs
sl@0	2708	* then the interpreter's result contains a standard error message. If
sl@0	2709	* complation fails because the set command requires a second level of
sl@0	2710	* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
sl@0	2711	* set command should be compiled "out of line" by emitting code to
sl@0	2712	* invoke its command procedure (Tcl_SetCmd) at runtime.
sl@0	2713	*
sl@0	2714	* Side effects:
sl@0	2715	* Instructions are added to envPtr to execute the "set" command
sl@0	2716	* at runtime.
sl@0	2717	*
sl@0	2718	*----------------------------------------------------------------------
sl@0	2719	*/
sl@0	2720
sl@0	2721	int
sl@0	2722	TclCompileSetCmd(interp, parsePtr, envPtr)
sl@0	2723	Tcl_Interp interp; / Used for error reporting. */
sl@0	2724	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	2725	* command created by Tcl_ParseCommand. */
sl@0	2726	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	2727	{
sl@0	2728	Tcl_Token varTokenPtr, valueTokenPtr;
sl@0	2729	int isAssignment, isScalar, simpleVarName, localIndex, numWords;
sl@0	2730	int code = TCL_OK;
sl@0	2731
sl@0	2732	#ifdef TCL_TIP280
sl@0	2733	/* TIP #280 : Remember the per-word line information of the current
sl@0	2734	* command. An index is used instead of a pointer as recursive compilation
sl@0	2735	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	2736	* the nuloc now, it may change during the course of the function.
sl@0	2737	*/
sl@0	2738	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	2739	int eclIndex = mapPtr->nuloc - 1;
sl@0	2740	#endif
sl@0	2741
sl@0	2742	numWords = parsePtr->numWords;
sl@0	2743	if ((numWords != 2) && (numWords != 3)) {
sl@0	2744	Tcl_ResetResult(interp);
sl@0	2745	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	2746	"wrong # args: should be \"set varName ?newValue?\"", -1);
sl@0	2747	return TCL_ERROR;
sl@0	2748	}
sl@0	2749	isAssignment = (numWords == 3);
sl@0	2750
sl@0	2751	/*
sl@0	2752	* Decide if we can use a frame slot for the var/array name or if we
sl@0	2753	* need to emit code to compute and push the name at runtime. We use a
sl@0	2754	* frame slot (entry in the array of local vars) if we are compiling a
sl@0	2755	* procedure body and if the name is simple text that does not include
sl@0	2756	* namespace qualifiers.
sl@0	2757	*/
sl@0	2758
sl@0	2759	varTokenPtr = parsePtr->tokenPtr
sl@0	2760	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	2761
sl@0	2762	code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
sl@0	2763	#ifndef TCL_TIP280
sl@0	2764	&localIndex, &simpleVarName, &isScalar);
sl@0	2765	#else
sl@0	2766	&localIndex, &simpleVarName, &isScalar,
sl@0	2767	mapPtr->loc [eclIndex].line [1]);
sl@0	2768	#endif
sl@0	2769	if (code != TCL_OK) {
sl@0	2770	goto done;
sl@0	2771	}
sl@0	2772
sl@0	2773	/*
sl@0	2774	* If we are doing an assignment, push the new value.
sl@0	2775	*/
sl@0	2776
sl@0	2777	if (isAssignment) {
sl@0	2778	valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	2779	if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2780	TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
sl@0	2781	valueTokenPtr[1].size), envPtr);
sl@0	2782	} else {
sl@0	2783	#ifdef TCL_TIP280
sl@0	2784	envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0	2785	#endif
sl@0	2786	code = TclCompileTokens(interp, valueTokenPtr+1,
sl@0	2787	valueTokenPtr->numComponents, envPtr);
sl@0	2788	if (code != TCL_OK) {
sl@0	2789	goto done;
sl@0	2790	}
sl@0	2791	}
sl@0	2792	}
sl@0	2793
sl@0	2794	/*
sl@0	2795	* Emit instructions to set/get the variable.
sl@0	2796	*/
sl@0	2797
sl@0	2798	if (simpleVarName) {
sl@0	2799	if (isScalar) {
sl@0	2800	if (localIndex >= 0) {
sl@0	2801	if (localIndex <= 255) {
sl@0	2802	TclEmitInstInt1((isAssignment?
sl@0	2803	INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
sl@0	2804	localIndex, envPtr);
sl@0	2805	} else {
sl@0	2806	TclEmitInstInt4((isAssignment?
sl@0	2807	INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
sl@0	2808	localIndex, envPtr);
sl@0	2809	}
sl@0	2810	} else {
sl@0	2811	TclEmitOpcode((isAssignment?
sl@0	2812	INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
sl@0	2813	}
sl@0	2814	} else {
sl@0	2815	if (localIndex >= 0) {
sl@0	2816	if (localIndex <= 255) {
sl@0	2817	TclEmitInstInt1((isAssignment?
sl@0	2818	INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
sl@0	2819	localIndex, envPtr);
sl@0	2820	} else {
sl@0	2821	TclEmitInstInt4((isAssignment?
sl@0	2822	INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
sl@0	2823	localIndex, envPtr);
sl@0	2824	}
sl@0	2825	} else {
sl@0	2826	TclEmitOpcode((isAssignment?
sl@0	2827	INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
sl@0	2828	}
sl@0	2829	}
sl@0	2830	} else {
sl@0	2831	TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
sl@0	2832	}
sl@0	2833
sl@0	2834	done:
sl@0	2835	return code;
sl@0	2836	}
sl@0	2837
sl@0	2838	/*
sl@0	2839	*----------------------------------------------------------------------
sl@0	2840	*
sl@0	2841	* TclCompileStringCmd --
sl@0	2842	*
sl@0	2843	* Procedure called to compile the "string" command.
sl@0	2844	*
sl@0	2845	* Results:
sl@0	2846	* The return value is a standard Tcl result, which is TCL_OK if the
sl@0	2847	* compilation was successful. If the command cannot be byte-compiled,
sl@0	2848	* TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
sl@0	2849	* interpreter's result contains an error message, and TCL_ERROR is
sl@0	2850	* returned.
sl@0	2851	*
sl@0	2852	* Side effects:
sl@0	2853	* Instructions are added to envPtr to execute the "string" command
sl@0	2854	* at runtime.
sl@0	2855	*
sl@0	2856	*----------------------------------------------------------------------
sl@0	2857	*/
sl@0	2858
sl@0	2859	int
sl@0	2860	TclCompileStringCmd(interp, parsePtr, envPtr)
sl@0	2861	Tcl_Interp interp; / Used for error reporting. */
sl@0	2862	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	2863	* command created by Tcl_ParseCommand. */
sl@0	2864	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	2865	{
sl@0	2866	Tcl_Token opTokenPtr, varTokenPtr;
sl@0	2867	Tcl_Obj *opObj;
sl@0	2868	int index;
sl@0	2869	int code;
sl@0	2870
sl@0	2871	static CONST char *options[] = {
sl@0	2872	"bytelength", "compare", "equal", "first",
sl@0	2873	"index", "is", "last", "length",
sl@0	2874	"map", "match", "range", "repeat",
sl@0	2875	"replace", "tolower", "toupper", "totitle",
sl@0	2876	"trim", "trimleft", "trimright",
sl@0	2877	"wordend", "wordstart", (char *) NULL
sl@0	2878	};
sl@0	2879	enum options {
sl@0	2880	STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
sl@0	2881	STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
sl@0	2882	STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
sl@0	2883	STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
sl@0	2884	STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
sl@0	2885	STR_WORDEND, STR_WORDSTART
sl@0	2886	};
sl@0	2887
sl@0	2888	#ifdef TCL_TIP280
sl@0	2889	/* TIP #280 : Remember the per-word line information of the current
sl@0	2890	* command. An index is used instead of a pointer as recursive compilation
sl@0	2891	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	2892	* the nuloc now, it may change during the course of the function.
sl@0	2893	*/
sl@0	2894	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	2895	int eclIndex = mapPtr->nuloc - 1;
sl@0	2896	#endif
sl@0	2897
sl@0	2898	if (parsePtr->numWords < 2) {
sl@0	2899	/* Fail at run time, not in compilation */
sl@0	2900	return TCL_OUT_LINE_COMPILE;
sl@0	2901	}
sl@0	2902	opTokenPtr = parsePtr->tokenPtr
sl@0	2903	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	2904
sl@0	2905	opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
sl@0	2906	if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
sl@0	2907	&index) != TCL_OK) {
sl@0	2908	Tcl_DecrRefCount(opObj);
sl@0	2909	Tcl_ResetResult(interp);
sl@0	2910	return TCL_OUT_LINE_COMPILE;
sl@0	2911	}
sl@0	2912	Tcl_DecrRefCount(opObj);
sl@0	2913
sl@0	2914	varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);
sl@0	2915
sl@0	2916	switch ((enum options) index) {
sl@0	2917	case STR_BYTELENGTH:
sl@0	2918	case STR_FIRST:
sl@0	2919	case STR_IS:
sl@0	2920	case STR_LAST:
sl@0	2921	case STR_MAP:
sl@0	2922	case STR_RANGE:
sl@0	2923	case STR_REPEAT:
sl@0	2924	case STR_REPLACE:
sl@0	2925	case STR_TOLOWER:
sl@0	2926	case STR_TOUPPER:
sl@0	2927	case STR_TOTITLE:
sl@0	2928	case STR_TRIM:
sl@0	2929	case STR_TRIMLEFT:
sl@0	2930	case STR_TRIMRIGHT:
sl@0	2931	case STR_WORDEND:
sl@0	2932	case STR_WORDSTART:
sl@0	2933	/*
sl@0	2934	* All other cases: compile out of line.
sl@0	2935	*/
sl@0	2936	return TCL_OUT_LINE_COMPILE;
sl@0	2937
sl@0	2938	case STR_COMPARE:
sl@0	2939	case STR_EQUAL: {
sl@0	2940	int i;
sl@0	2941	/*
sl@0	2942	* If there are any flags to the command, we can't byte compile it
sl@0	2943	* because the INST_STR_EQ bytecode doesn't support flags.
sl@0	2944	*/
sl@0	2945
sl@0	2946	if (parsePtr->numWords != 4) {
sl@0	2947	return TCL_OUT_LINE_COMPILE;
sl@0	2948	}
sl@0	2949
sl@0	2950	/*
sl@0	2951	* Push the two operands onto the stack.
sl@0	2952	*/
sl@0	2953
sl@0	2954	for (i = 0; i < 2; i++) {
sl@0	2955	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2956	TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0	2957	varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
sl@0	2958	} else {
sl@0	2959	#ifdef TCL_TIP280
sl@0	2960	envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0	2961	#endif
sl@0	2962	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	2963	varTokenPtr->numComponents, envPtr);
sl@0	2964	if (code != TCL_OK) {
sl@0	2965	return code;
sl@0	2966	}
sl@0	2967	}
sl@0	2968	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	2969	}
sl@0	2970
sl@0	2971	TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
sl@0	2972	INST_STR_CMP : INST_STR_EQ), envPtr);
sl@0	2973	return TCL_OK;
sl@0	2974	}
sl@0	2975	case STR_INDEX: {
sl@0	2976	int i;
sl@0	2977
sl@0	2978	if (parsePtr->numWords != 4) {
sl@0	2979	/* Fail at run time, not in compilation */
sl@0	2980	return TCL_OUT_LINE_COMPILE;
sl@0	2981	}
sl@0	2982
sl@0	2983	/*
sl@0	2984	* Push the two operands onto the stack.
sl@0	2985	*/
sl@0	2986
sl@0	2987	for (i = 0; i < 2; i++) {
sl@0	2988	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	2989	TclEmitPush(TclRegisterNewLiteral(envPtr,
sl@0	2990	varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
sl@0	2991	} else {
sl@0	2992	#ifdef TCL_TIP280
sl@0	2993	envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0	2994	#endif
sl@0	2995	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	2996	varTokenPtr->numComponents, envPtr);
sl@0	2997	if (code != TCL_OK) {
sl@0	2998	return code;
sl@0	2999	}
sl@0	3000	}
sl@0	3001	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	3002	}
sl@0	3003
sl@0	3004	TclEmitOpcode(INST_STR_INDEX, envPtr);
sl@0	3005	return TCL_OK;
sl@0	3006	}
sl@0	3007	case STR_LENGTH: {
sl@0	3008	if (parsePtr->numWords != 3) {
sl@0	3009	/* Fail at run time, not in compilation */
sl@0	3010	return TCL_OUT_LINE_COMPILE;
sl@0	3011	}
sl@0	3012
sl@0	3013	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	3014	/*
sl@0	3015	* Here someone is asking for the length of a static string.
sl@0	3016	* Just push the actual character (not byte) length.
sl@0	3017	*/
sl@0	3018	char buf[TCL_INTEGER_SPACE];
sl@0	3019	int len = Tcl_NumUtfChars(varTokenPtr[1].start,
sl@0	3020	varTokenPtr[1].size);
sl@0	3021	len = sprintf(buf, "%d", len);
sl@0	3022	TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
sl@0	3023	return TCL_OK;
sl@0	3024	} else {
sl@0	3025	#ifdef TCL_TIP280
sl@0	3026	envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0	3027	#endif
sl@0	3028	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	3029	varTokenPtr->numComponents, envPtr);
sl@0	3030	if (code != TCL_OK) {
sl@0	3031	return code;
sl@0	3032	}
sl@0	3033	}
sl@0	3034	TclEmitOpcode(INST_STR_LEN, envPtr);
sl@0	3035	return TCL_OK;
sl@0	3036	}
sl@0	3037	case STR_MATCH: {
sl@0	3038	int i, length, exactMatch = 0, nocase = 0;
sl@0	3039	CONST char *str;
sl@0	3040
sl@0	3041	if (parsePtr->numWords < 4 \|\| parsePtr->numWords > 5) {
sl@0	3042	/* Fail at run time, not in compilation */
sl@0	3043	return TCL_OUT_LINE_COMPILE;
sl@0	3044	}
sl@0	3045
sl@0	3046	if (parsePtr->numWords == 5) {
sl@0	3047	if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
sl@0	3048	return TCL_OUT_LINE_COMPILE;
sl@0	3049	}
sl@0	3050	str = varTokenPtr[1].start;
sl@0	3051	length = varTokenPtr[1].size;
sl@0	3052	if ((length > 1) &&
sl@0	3053	strncmp(str, "-nocase", (size_t) length) == 0) {
sl@0	3054	nocase = 1;
sl@0	3055	} else {
sl@0	3056	/* Fail at run time, not in compilation */
sl@0	3057	return TCL_OUT_LINE_COMPILE;
sl@0	3058	}
sl@0	3059	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	3060	}
sl@0	3061
sl@0	3062	for (i = 0; i < 2; i++) {
sl@0	3063	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	3064	str = varTokenPtr[1].start;
sl@0	3065	length = varTokenPtr[1].size;
sl@0	3066	if (!nocase && (i == 0)) {
sl@0	3067	/*
sl@0	3068	* On the first (pattern) arg, check to see if any
sl@0	3069	* glob special characters are in the word '*[]?\\'.
sl@0	3070	* If not, this is the same as 'string equal'. We
sl@0	3071	* can use strpbrk here because the glob chars are all
sl@0	3072	* in the ascii-7 range. If -nocase was specified,
sl@0	3073	* we can't do this because INST_STR_EQ has no support
sl@0	3074	* for nocase.
sl@0	3075	*/
sl@0	3076	Tcl_Obj *copy = Tcl_NewStringObj(str, length);
sl@0	3077	Tcl_IncrRefCount(copy);
sl@0	3078	exactMatch = (strpbrk(Tcl_GetString(copy),
sl@0	3079	"*[]?\\") == NULL);
sl@0	3080	Tcl_DecrRefCount(copy);
sl@0	3081	}
sl@0	3082	TclEmitPush(
sl@0	3083	TclRegisterNewLiteral(envPtr, str, length), envPtr);
sl@0	3084	} else {
sl@0	3085	#ifdef TCL_TIP280
sl@0	3086	envPtr->line = mapPtr->loc [eclIndex].line [i];
sl@0	3087	#endif
sl@0	3088	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	3089	varTokenPtr->numComponents, envPtr);
sl@0	3090	if (code != TCL_OK) {
sl@0	3091	return code;
sl@0	3092	}
sl@0	3093	}
sl@0	3094	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	3095	}
sl@0	3096
sl@0	3097	if (exactMatch) {
sl@0	3098	TclEmitOpcode(INST_STR_EQ, envPtr);
sl@0	3099	} else {
sl@0	3100	TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
sl@0	3101	}
sl@0	3102	return TCL_OK;
sl@0	3103	}
sl@0	3104	}
sl@0	3105
sl@0	3106	return TCL_OK;
sl@0	3107	}
sl@0	3108
sl@0	3109	/*
sl@0	3110	*----------------------------------------------------------------------
sl@0	3111	*
sl@0	3112	* TclCompileVariableCmd --
sl@0	3113	*
sl@0	3114	* Procedure called to reserve the local variables for the
sl@0	3115	* "variable" command. The command itself is not compiled.
sl@0	3116	*
sl@0	3117	* Results:
sl@0	3118	* Always returns TCL_OUT_LINE_COMPILE.
sl@0	3119	*
sl@0	3120	* Side effects:
sl@0	3121	* Indexed local variables are added to the environment.
sl@0	3122	*
sl@0	3123	*----------------------------------------------------------------------
sl@0	3124	*/
sl@0	3125	int
sl@0	3126	TclCompileVariableCmd(interp, parsePtr, envPtr)
sl@0	3127	Tcl_Interp interp; / Used for error reporting. */
sl@0	3128	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	3129	* command created by Tcl_ParseCommand. */
sl@0	3130	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	3131	{
sl@0	3132	Tcl_Token *varTokenPtr;
sl@0	3133	int i, numWords;
sl@0	3134	CONST char varName, tail;
sl@0	3135
sl@0	3136	if (envPtr->procPtr == NULL) {
sl@0	3137	return TCL_OUT_LINE_COMPILE;
sl@0	3138	}
sl@0	3139
sl@0	3140	numWords = parsePtr->numWords;
sl@0	3141
sl@0	3142	varTokenPtr = parsePtr->tokenPtr
sl@0	3143	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	3144	for (i = 1; i < numWords; i += 2) {
sl@0	3145	if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
sl@0	3146	varName = varTokenPtr[1].start;
sl@0	3147	tail = varName + varTokenPtr[1].size - 1;
sl@0	3148	if ((*tail == ')') \|\| (tail < varName)) continue;
sl@0	3149	while ((tail > varName) && ((tail != ':') \|\| ((tail-1) != ':'))) {
sl@0	3150	tail--;
sl@0	3151	}
sl@0	3152	if ((*tail == ':') && (tail > varName)) {
sl@0	3153	tail++;
sl@0	3154	}
sl@0	3155	(void) TclFindCompiledLocal(tail, (tail-varName+1),
sl@0	3156	/create/ 1, /flags/ 0, envPtr->procPtr);
sl@0	3157	varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
sl@0	3158	}
sl@0	3159	}
sl@0	3160	return TCL_OUT_LINE_COMPILE;
sl@0	3161	}
sl@0	3162
sl@0	3163	/*
sl@0	3164	*----------------------------------------------------------------------
sl@0	3165	*
sl@0	3166	* TclCompileWhileCmd --
sl@0	3167	*
sl@0	3168	* Procedure called to compile the "while" command.
sl@0	3169	*
sl@0	3170	* Results:
sl@0	3171	* The return value is a standard Tcl result, which is TCL_OK if
sl@0	3172	* compilation was successful. If an error occurs then the
sl@0	3173	* interpreter's result contains a standard error message and TCL_ERROR
sl@0	3174	* is returned. If compilation failed because the command is too
sl@0	3175	* complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
sl@0	3176	* indicating that the while command should be compiled "out of line"
sl@0	3177	* by emitting code to invoke its command procedure at runtime.
sl@0	3178	*
sl@0	3179	* Side effects:
sl@0	3180	* Instructions are added to envPtr to execute the "while" command
sl@0	3181	* at runtime.
sl@0	3182	*
sl@0	3183	*----------------------------------------------------------------------
sl@0	3184	*/
sl@0	3185
sl@0	3186	int
sl@0	3187	TclCompileWhileCmd(interp, parsePtr, envPtr)
sl@0	3188	Tcl_Interp interp; / Used for error reporting. */
sl@0	3189	Tcl_Parse parsePtr; / Points to a parse structure for the
sl@0	3190	* command created by Tcl_ParseCommand. */
sl@0	3191	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	3192	{
sl@0	3193	Tcl_Token testTokenPtr, bodyTokenPtr;
sl@0	3194	JumpFixup jumpEvalCondFixup;
sl@0	3195	int testCodeOffset, bodyCodeOffset, jumpDist;
sl@0	3196	int range, code;
sl@0	3197	char buffer[32 + TCL_INTEGER_SPACE];
sl@0	3198	int savedStackDepth = envPtr->currStackDepth;
sl@0	3199	int loopMayEnd = 1; /* This is set to 0 if it is recognized as
sl@0	3200	* an infinite loop. */
sl@0	3201	Tcl_Obj *boolObj;
sl@0	3202	int boolVal;
sl@0	3203
sl@0	3204	#ifdef TCL_TIP280
sl@0	3205	/* TIP #280 : Remember the per-word line information of the current
sl@0	3206	* command. An index is used instead of a pointer as recursive compilation
sl@0	3207	* may reallocate, i.e. move, the array. This is also the reason to save
sl@0	3208	* the nuloc now, it may change during the course of the function.
sl@0	3209	*/
sl@0	3210	ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
sl@0	3211	int eclIndex = mapPtr->nuloc - 1;
sl@0	3212	#endif
sl@0	3213
sl@0	3214	if (parsePtr->numWords != 3) {
sl@0	3215	Tcl_ResetResult(interp);
sl@0	3216	Tcl_AppendToObj(Tcl_GetObjResult(interp),
sl@0	3217	"wrong # args: should be \"while test command\"", -1);
sl@0	3218	return TCL_ERROR;
sl@0	3219	}
sl@0	3220
sl@0	3221	/*
sl@0	3222	* If the test expression requires substitutions, don't compile the
sl@0	3223	* while command inline. E.g., the expression might cause the loop to
sl@0	3224	* never execute or execute forever, as in "while "$x < 5" {}".
sl@0	3225	*
sl@0	3226	* Bail out also if the body expression requires substitutions
sl@0	3227	* in order to insure correct behaviour [Bug 219166]
sl@0	3228	*/
sl@0	3229
sl@0	3230	testTokenPtr = parsePtr->tokenPtr
sl@0	3231	+ (parsePtr->tokenPtr->numComponents + 1);
sl@0	3232	bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
sl@0	3233	if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
sl@0	3234	\|\| (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
sl@0	3235	return TCL_OUT_LINE_COMPILE;
sl@0	3236	}
sl@0	3237
sl@0	3238	/*
sl@0	3239	* Find out if the condition is a constant.
sl@0	3240	*/
sl@0	3241
sl@0	3242	boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
sl@0	3243	Tcl_IncrRefCount(boolObj);
sl@0	3244	code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
sl@0	3245	Tcl_DecrRefCount(boolObj);
sl@0	3246	if (code == TCL_OK) {
sl@0	3247	if (boolVal) {
sl@0	3248	/*
sl@0	3249	* it is an infinite loop
sl@0	3250	*/
sl@0	3251
sl@0	3252	loopMayEnd = 0;
sl@0	3253	} else {
sl@0	3254	/*
sl@0	3255	* This is an empty loop: "while 0 {...}" or such.
sl@0	3256	* Compile no bytecodes.
sl@0	3257	*/
sl@0	3258
sl@0	3259	goto pushResult;
sl@0	3260	}
sl@0	3261	}
sl@0	3262
sl@0	3263	/*
sl@0	3264	* Create a ExceptionRange record for the loop body. This is used to
sl@0	3265	* implement break and continue.
sl@0	3266	*/
sl@0	3267
sl@0	3268	envPtr->exceptDepth++;
sl@0	3269	envPtr->maxExceptDepth =
sl@0	3270	TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
sl@0	3271	range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
sl@0	3272
sl@0	3273	/*
sl@0	3274	* Jump to the evaluation of the condition. This code uses the "loop
sl@0	3275	* rotation" optimisation (which eliminates one branch from the loop).
sl@0	3276	* "while cond body" produces then:
sl@0	3277	* goto A
sl@0	3278	* B: body : bodyCodeOffset
sl@0	3279	* A: cond -> result : testCodeOffset, continueOffset
sl@0	3280	* if (result) goto B
sl@0	3281	*
sl@0	3282	* The infinite loop "while 1 body" produces:
sl@0	3283	* B: body : all three offsets here
sl@0	3284	* goto B
sl@0	3285	*/
sl@0	3286
sl@0	3287	if (loopMayEnd) {
sl@0	3288	TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
sl@0	3289	testCodeOffset = 0; /* avoid compiler warning */
sl@0	3290	} else {
sl@0	3291	testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	3292	}
sl@0	3293
sl@0	3294
sl@0	3295	/*
sl@0	3296	* Compile the loop body.
sl@0	3297	*/
sl@0	3298
sl@0	3299	#ifdef TCL_TIP280
sl@0	3300	envPtr->line = mapPtr->loc [eclIndex].line [2];
sl@0	3301	#endif
sl@0	3302	bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	3303	code = TclCompileCmdWord(interp, bodyTokenPtr+1,
sl@0	3304	bodyTokenPtr->numComponents, envPtr);
sl@0	3305	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	3306	if (code != TCL_OK) {
sl@0	3307	if (code == TCL_ERROR) {
sl@0	3308	sprintf(buffer, "\n (\"while\" body line %d)",
sl@0	3309	interp->errorLine);
sl@0	3310	Tcl_AddObjErrorInfo(interp, buffer, -1);
sl@0	3311	}
sl@0	3312	goto error;
sl@0	3313	}
sl@0	3314	envPtr->exceptArrayPtr[range].numCodeBytes =
sl@0	3315	(envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0	3316	TclEmitOpcode(INST_POP, envPtr);
sl@0	3317
sl@0	3318	/*
sl@0	3319	* Compile the test expression then emit the conditional jump that
sl@0	3320	* terminates the while. We already know it's a simple word.
sl@0	3321	*/
sl@0	3322
sl@0	3323	if (loopMayEnd) {
sl@0	3324	testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
sl@0	3325	jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
sl@0	3326	if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
sl@0	3327	bodyCodeOffset += 3;
sl@0	3328	testCodeOffset += 3;
sl@0	3329	}
sl@0	3330	envPtr->currStackDepth = savedStackDepth;
sl@0	3331	#ifdef TCL_TIP280
sl@0	3332	envPtr->line = mapPtr->loc [eclIndex].line [1];
sl@0	3333	#endif
sl@0	3334	code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
sl@0	3335	if (code != TCL_OK) {
sl@0	3336	if (code == TCL_ERROR) {
sl@0	3337	Tcl_AddObjErrorInfo(interp,
sl@0	3338	"\n (\"while\" test expression)", -1);
sl@0	3339	}
sl@0	3340	goto error;
sl@0	3341	}
sl@0	3342	envPtr->currStackDepth = savedStackDepth + 1;
sl@0	3343
sl@0	3344	jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0	3345	if (jumpDist > 127) {
sl@0	3346	TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
sl@0	3347	} else {
sl@0	3348	TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
sl@0	3349	}
sl@0	3350	} else {
sl@0	3351	jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
sl@0	3352	if (jumpDist > 127) {
sl@0	3353	TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
sl@0	3354	} else {
sl@0	3355	TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
sl@0	3356	}
sl@0	3357	}
sl@0	3358
sl@0	3359
sl@0	3360	/*
sl@0	3361	* Set the loop's body, continue and break offsets.
sl@0	3362	*/
sl@0	3363
sl@0	3364	envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
sl@0	3365	envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
sl@0	3366	envPtr->exceptArrayPtr[range].breakOffset =
sl@0	3367	(envPtr->codeNext - envPtr->codeStart);
sl@0	3368
sl@0	3369	/*
sl@0	3370	* The while command's result is an empty string.
sl@0	3371	*/
sl@0	3372
sl@0	3373	pushResult:
sl@0	3374	envPtr->currStackDepth = savedStackDepth;
sl@0	3375	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0	3376	envPtr->exceptDepth--;
sl@0	3377	return TCL_OK;
sl@0	3378
sl@0	3379	error:
sl@0	3380	envPtr->exceptDepth--;
sl@0	3381	return code;
sl@0	3382	}
sl@0	3383
sl@0	3384	/*
sl@0	3385	*----------------------------------------------------------------------
sl@0	3386	*
sl@0	3387	* TclPushVarName --
sl@0	3388	*
sl@0	3389	* Procedure used in the compiling where pushing a variable name
sl@0	3390	* is necessary (append, lappend, set).
sl@0	3391	*
sl@0	3392	* Results:
sl@0	3393	* The return value is a standard Tcl result, which is normally TCL_OK
sl@0	3394	* unless there was an error while parsing string. If an error occurs
sl@0	3395	* then the interpreter's result contains a standard error message.
sl@0	3396	*
sl@0	3397	* Side effects:
sl@0	3398	* Instructions are added to envPtr to execute the "set" command
sl@0	3399	* at runtime.
sl@0	3400	*
sl@0	3401	*----------------------------------------------------------------------
sl@0	3402	*/
sl@0	3403
sl@0	3404	static int
sl@0	3405	TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
sl@0	3406	#ifndef TCL_TIP280
sl@0	3407	simpleVarNamePtr, isScalarPtr)
sl@0	3408	#else
sl@0	3409	simpleVarNamePtr, isScalarPtr, line)
sl@0	3410	#endif
sl@0	3411	Tcl_Interp interp; / Used for error reporting. */
sl@0	3412	Tcl_Token varTokenPtr; / Points to a variable token. */
sl@0	3413	CompileEnv envPtr; / Holds resulting instructions. */
sl@0	3414	int flags; /* takes TCL_CREATE_VAR or
sl@0	3415	* TCL_NO_LARGE_INDEX */
sl@0	3416	int localIndexPtr; / must not be NULL */
sl@0	3417	int simpleVarNamePtr; / must not be NULL */
sl@0	3418	int isScalarPtr; / must not be NULL */
sl@0	3419	#ifdef TCL_TIP280
sl@0	3420	int line; /* line the token starts on */
sl@0	3421	#endif
sl@0	3422	{
sl@0	3423	register CONST char *p;
sl@0	3424	CONST char name, elName;
sl@0	3425	register int i, n;
sl@0	3426	int nameChars, elNameChars, simpleVarName, localIndex;
sl@0	3427	int code = TCL_OK;
sl@0	3428
sl@0	3429	Tcl_Token *elemTokenPtr = NULL;
sl@0	3430	int elemTokenCount = 0;
sl@0	3431	int allocedTokens = 0;
sl@0	3432	int removedParen = 0;
sl@0	3433
sl@0	3434	/*
sl@0	3435	* Decide if we can use a frame slot for the var/array name or if we
sl@0	3436	* need to emit code to compute and push the name at runtime. We use a
sl@0	3437	* frame slot (entry in the array of local vars) if we are compiling a
sl@0	3438	* procedure body and if the name is simple text that does not include
sl@0	3439	* namespace qualifiers.
sl@0	3440	*/
sl@0	3441
sl@0	3442	simpleVarName = 0;
sl@0	3443	name = elName = NULL;
sl@0	3444	nameChars = elNameChars = 0;
sl@0	3445	localIndex = -1;
sl@0	3446
sl@0	3447	/*
sl@0	3448	* Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
sl@0	3449	* curly braces surround the variable name.
sl@0	3450	* This really matters for array elements to handle things like
sl@0	3451	* set {x($foo)} 5
sl@0	3452	* which raises an undefined var error if we are not careful here.
sl@0	3453	*/
sl@0	3454
sl@0	3455	if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
sl@0	3456	(varTokenPtr->start[0] != '{')) {
sl@0	3457	/*
sl@0	3458	* A simple variable name. Divide it up into "name" and "elName"
sl@0	3459	* strings. If it is not a local variable, look it up at runtime.
sl@0	3460	*/
sl@0	3461	simpleVarName = 1;
sl@0	3462
sl@0	3463	name = varTokenPtr[1].start;
sl@0	3464	nameChars = varTokenPtr[1].size;
sl@0	3465	if ( *(name + nameChars - 1) == ')') {
sl@0	3466	/*
sl@0	3467	* last char is ')' => potential array reference.
sl@0	3468	*/
sl@0	3469
sl@0	3470	for (i = 0, p = name; i < nameChars; i++, p++) {
sl@0	3471	if (*p == '(') {
sl@0	3472	elName = p + 1;
sl@0	3473	elNameChars = nameChars - i - 2;
sl@0	3474	nameChars = i ;
sl@0	3475	break;
sl@0	3476	}
sl@0	3477	}
sl@0	3478
sl@0	3479	if ((elName != NULL) && elNameChars) {
sl@0	3480	/*
sl@0	3481	* An array element, the element name is a simple
sl@0	3482	* string: assemble the corresponding token.
sl@0	3483	*/
sl@0	3484
sl@0	3485	elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
sl@0	3486	allocedTokens = 1;
sl@0	3487	elemTokenPtr->type = TCL_TOKEN_TEXT;
sl@0	3488	elemTokenPtr->start = elName;
sl@0	3489	elemTokenPtr->size = elNameChars;
sl@0	3490	elemTokenPtr->numComponents = 0;
sl@0	3491	elemTokenCount = 1;
sl@0	3492	}
sl@0	3493	}
sl@0	3494	} else if (((n = varTokenPtr->numComponents) > 1)
sl@0	3495	&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
sl@0	3496	&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
sl@0	3497	&& (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
sl@0	3498
sl@0	3499	/*
sl@0	3500	* Check for parentheses inside first token
sl@0	3501	*/
sl@0	3502
sl@0	3503	simpleVarName = 0;
sl@0	3504	for (i = 0, p = varTokenPtr[1].start;
sl@0	3505	i < varTokenPtr[1].size; i++, p++) {
sl@0	3506	if (*p == '(') {
sl@0	3507	simpleVarName = 1;
sl@0	3508	break;
sl@0	3509	}
sl@0	3510	}
sl@0	3511	if (simpleVarName) {
sl@0	3512	int remainingChars;
sl@0	3513
sl@0	3514	/*
sl@0	3515	* Check the last token: if it is just ')', do not count
sl@0	3516	* it. Otherwise, remove the ')' and flag so that it is
sl@0	3517	* restored at the end.
sl@0	3518	*/
sl@0	3519
sl@0	3520	if (varTokenPtr[n].size == 1) {
sl@0	3521	--n;
sl@0	3522	} else {
sl@0	3523	--varTokenPtr[n].size;
sl@0	3524	removedParen = n;
sl@0	3525	}
sl@0	3526
sl@0	3527	name = varTokenPtr[1].start;
sl@0	3528	nameChars = p - varTokenPtr[1].start;
sl@0	3529	elName = p + 1;
sl@0	3530	remainingChars = (varTokenPtr[2].start - p) - 1;
sl@0	3531	elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
sl@0	3532
sl@0	3533	if (remainingChars) {
sl@0	3534	/*
sl@0	3535	* Make a first token with the extra characters in the first
sl@0	3536	* token.
sl@0	3537	*/
sl@0	3538
sl@0	3539	elemTokenPtr = (Tcl_Token ) ckalloc(n sizeof(Tcl_Token));
sl@0	3540	allocedTokens = 1;
sl@0	3541	elemTokenPtr->type = TCL_TOKEN_TEXT;
sl@0	3542	elemTokenPtr->start = elName;
sl@0	3543	elemTokenPtr->size = remainingChars;
sl@0	3544	elemTokenPtr->numComponents = 0;
sl@0	3545	elemTokenCount = n;
sl@0	3546
sl@0	3547	/*
sl@0	3548	* Copy the remaining tokens.
sl@0	3549	*/
sl@0	3550
sl@0	3551	memcpy((void ) (elemTokenPtr+1), (void ) (&varTokenPtr[2]),
sl@0	3552	((n-1) * sizeof(Tcl_Token)));
sl@0	3553	} else {
sl@0	3554	/*
sl@0	3555	* Use the already available tokens.
sl@0	3556	*/
sl@0	3557
sl@0	3558	elemTokenPtr = &varTokenPtr[2];
sl@0	3559	elemTokenCount = n - 1;
sl@0	3560	}
sl@0	3561	}
sl@0	3562	}
sl@0	3563
sl@0	3564	if (simpleVarName) {
sl@0	3565	/*
sl@0	3566	* See whether name has any namespace separators (::'s).
sl@0	3567	*/
sl@0	3568
sl@0	3569	int hasNsQualifiers = 0;
sl@0	3570	for (i = 0, p = name; i < nameChars; i++, p++) {
sl@0	3571	if ((p == ':') && ((i+1) < nameChars) && ((p+1) == ':')) {
sl@0	3572	hasNsQualifiers = 1;
sl@0	3573	break;
sl@0	3574	}
sl@0	3575	}
sl@0	3576
sl@0	3577	/*
sl@0	3578	* Look up the var name's index in the array of local vars in the
sl@0	3579	* proc frame. If retrieving the var's value and it doesn't already
sl@0	3580	* exist, push its name and look it up at runtime.
sl@0	3581	*/
sl@0	3582
sl@0	3583	if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
sl@0	3584	localIndex = TclFindCompiledLocal(name, nameChars,
sl@0	3585	/create/ (flags & TCL_CREATE_VAR),
sl@0	3586	/flags/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
sl@0	3587	envPtr->procPtr);
sl@0	3588	if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
sl@0	3589	/* we'll push the name */
sl@0	3590	localIndex = -1;
sl@0	3591	}
sl@0	3592	}
sl@0	3593	if (localIndex < 0) {
sl@0	3594	TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
sl@0	3595	}
sl@0	3596
sl@0	3597	/*
sl@0	3598	* Compile the element script, if any.
sl@0	3599	*/
sl@0	3600
sl@0	3601	if (elName != NULL) {
sl@0	3602	if (elNameChars) {
sl@0	3603	#ifdef TCL_TIP280
sl@0	3604	envPtr->line = line;
sl@0	3605	#endif
sl@0	3606	code = TclCompileTokens(interp, elemTokenPtr,
sl@0	3607	elemTokenCount, envPtr);
sl@0	3608	if (code != TCL_OK) {
sl@0	3609	goto done;
sl@0	3610	}
sl@0	3611	} else {
sl@0	3612	TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
sl@0	3613	}
sl@0	3614	}
sl@0	3615	} else {
sl@0	3616	/*
sl@0	3617	* The var name isn't simple: compile and push it.
sl@0	3618	*/
sl@0	3619
sl@0	3620	#ifdef TCL_TIP280
sl@0	3621	envPtr->line = line;
sl@0	3622	#endif
sl@0	3623	code = TclCompileTokens(interp, varTokenPtr+1,
sl@0	3624	varTokenPtr->numComponents, envPtr);
sl@0	3625	if (code != TCL_OK) {
sl@0	3626	goto done;
sl@0	3627	}
sl@0	3628	}
sl@0	3629
sl@0	3630	done:
sl@0	3631	if (removedParen) {
sl@0	3632	++varTokenPtr[removedParen].size;
sl@0	3633	}
sl@0	3634	if (allocedTokens) {
sl@0	3635	ckfree((char *) elemTokenPtr);
sl@0	3636	}
sl@0	3637	*localIndexPtr = localIndex;
sl@0	3638	*simpleVarNamePtr = simpleVarName;
sl@0	3639	*isScalarPtr = (elName == NULL);
sl@0	3640	return code;
sl@0	3641	}
sl@0	3642
sl@0	3643	/*
sl@0	3644	* Local Variables:
sl@0	3645	* mode: c
sl@0	3646	* c-basic-offset: 4
sl@0	3647	* fill-column: 78
sl@0	3648	* End:
sl@0	3649	*/
sl@0	3650

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--