summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c207
1 files changed, 131 insertions, 76 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a41351e..a09bf10 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -211,7 +211,7 @@ static const CmdInfo builtInCmds[] = {
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
- {"concat", Tcl_ConcatObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE},
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
@@ -227,7 +227,7 @@ static const CmdInfo builtInCmds[] = {
{"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE},
{"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE},
{"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
- {"linsert", Tcl_LinsertObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE},
{"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
{"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
{"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
@@ -259,7 +259,7 @@ static const CmdInfo builtInCmds[] = {
{"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE},
{"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE},
{"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE},
- {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE},
+ {"yieldto", NULL, TclCompileYieldToCmd, TclNRYieldToObjCmd, CMD_IS_SAFE},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
@@ -472,7 +472,6 @@ Tcl_CreateInterp(void)
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
- int result;
TclInitSubsystems();
@@ -526,6 +525,9 @@ Tcl_CreateInterp(void)
iPtr->hiddenCmdTablePtr = NULL;
iPtr->interpInfo = NULL;
+ TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable));
+ iPtr->extra.optimizer = TclOptimizeBytecode;
+
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL; /* Initialise as soon as :: is available */
@@ -639,11 +641,8 @@ Tcl_CreateInterp(void)
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
framePtr = ckalloc(sizeof(CallFrame));
- result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
+ (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
- if (result != TCL_OK) {
- Tcl_Panic("Tcl_CreateInterp: failed to push the root stack frame");
- }
framePtr->objc = 0;
iPtr->framePtr = framePtr;
@@ -837,7 +836,9 @@ Tcl_CreateInterp(void)
*/
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
- Tcl_DisassembleObjCmd, NULL, NULL);
+ Tcl_DisassembleObjCmd, INT2PTR(0), NULL);
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::getbytecode",
+ Tcl_DisassembleObjCmd, INT2PTR(1), NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
Tcl_RepresentationCmd, NULL, NULL);
@@ -2082,10 +2083,19 @@ Tcl_CreateCommand(
*/
cmdPtr = Tcl_GetHashValue(hPtr);
- oldRefPtr = cmdPtr->importRefPtr;
- cmdPtr->importRefPtr = NULL;
+ cmdPtr->refCount++;
+ if (cmdPtr->importRefPtr) {
+ cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
+ }
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+
+ if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
+ oldRefPtr = cmdPtr->importRefPtr;
+ cmdPtr->importRefPtr = NULL;
+ }
+ TclCleanupCommandMacro(cmdPtr);
+
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
if (!isNew) {
/*
@@ -2246,7 +2256,7 @@ Tcl_CreateObjCommand(
/* Command already exists. */
/*
- * [***] This is wrong. See Tcl Bug a16752c252.
+ * [***] This is wrong. See Tcl Bug a16752c252.
* However, this buggy behavior is kept under particular
* circumstances to accommodate deployed binaries of the
* "tclcompiler" program. http://sourceforge.net/projects/tclpro/
@@ -2269,10 +2279,19 @@ Tcl_CreateObjCommand(
* intact.
*/
- oldRefPtr = cmdPtr->importRefPtr;
- cmdPtr->importRefPtr = NULL;
+ cmdPtr->refCount++;
+ if (cmdPtr->importRefPtr) {
+ cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
+ }
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
+
+ if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
+ oldRefPtr = cmdPtr->importRefPtr;
+ cmdPtr->importRefPtr = NULL;
+ }
+ TclCleanupCommandMacro(cmdPtr);
+
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
if (!isNew) {
/*
@@ -3061,7 +3080,7 @@ Tcl_DeleteCommandFromToken(
while (tracePtr != NULL) {
CommandTrace *nextPtr = tracePtr->nextPtr;
- if ((--tracePtr->refCount) <= 0) {
+ if (tracePtr->refCount-- <= 1) {
ckfree(tracePtr);
}
tracePtr = nextPtr;
@@ -3114,12 +3133,13 @@ Tcl_DeleteCommandFromToken(
* commands were created that refer back to this command. Delete these
* imported commands now.
*/
-
- for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
- refPtr = nextRefPtr) {
- nextRefPtr = refPtr->nextPtr;
- importCmd = (Tcl_Command) refPtr->importedCmdPtr;
- Tcl_DeleteCommandFromToken(interp, importCmd);
+ if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) {
+ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
+ refPtr = nextRefPtr) {
+ nextRefPtr = refPtr->nextPtr;
+ importCmd = (Tcl_Command) refPtr->importedCmdPtr;
+ Tcl_DeleteCommandFromToken(interp, importCmd);
+ }
}
/*
@@ -3246,7 +3266,7 @@ CallCommandTraces(
tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
oldName, newName, flags);
cmdPtr->flags &= ~tracePtr->flags;
- if ((--tracePtr->refCount) <= 0) {
+ if (tracePtr->refCount-- <= 1) {
ckfree(tracePtr);
}
}
@@ -4118,8 +4138,9 @@ TclNREvalObjv(
/*
* data[1] stores a marker for use by tailcalls; it will be set to 1 by
- * command redirectors (imports, alias, ensembles) so that tailcalls
- * finishes the source command and not just the target.
+ * command redirectors (imports, alias, ensembles) so that tailcall skips
+ * this callback (that marks the end of the target command) and goes back
+ * to the end of the source command.
*/
if (iPtr->deferredCallbacks) {
@@ -4147,7 +4168,7 @@ EvalObjvCore(
Interp *iPtr = (Interp *) interp;
Namespace *lookupNsPtr = NULL;
int enterTracesDone = 0;
-
+
/*
* Push records for task to be done on return, in INVERSE order. First, if
* needed, the exception handlers (as they should happen last).
@@ -4273,7 +4294,7 @@ EvalObjvCore(
}
}
- /*
+ /*
* Schedule leave traces. Raise the refCount on the resolved
* cmdPtr, so that when it passes to the leave traces we know
* it's still valid.
@@ -4382,9 +4403,9 @@ NRCommand(
iPtr->numLevels--;
/*
- * If there is a tailcall, schedule it
+ * If there is a tailcall, schedule it next
*/
-
+
if (data[1] && (data[1] != INT2PTR(1))) {
TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
}
@@ -5618,10 +5639,10 @@ TclArgumentBCEnter(
* ensemble dispatch. Ensemble subcommands that lead to script
* evaluation are not supposed to get compiled, because a command
* such as [info level] in the script can expose some of the dispatch
- * shenanigans. This means that we don't have to tend to the
+ * shenanigans. This means that we don't have to tend to the
* housekeeping, and can escape now.
*/
-
+
if (ePtr->nline != objc) {
return;
}
@@ -5885,7 +5906,7 @@ Tcl_GlobalEvalObj(
*
* If the flag TCL_EVAL_DIRECT is passed in, the value of invoker
* must be NULL. Support for non-NULL invokers in that mode has
- * been removed since it was unused and untested. Failure to
+ * been removed since it was unused and untested. Failure to
* follow this limitation will lead to an assertion panic.
*
* Results:
@@ -6493,11 +6514,7 @@ TclObjInvokeNamespace(
* command.
*/
- result = TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
+ (void) TclPushStackFrame(interp, &framePtr, nsPtr, /*isProcFrame*/0);
result = TclObjInvoke(interp, objc, objv, flags);
TclPopStackFrame(interp);
@@ -8146,27 +8163,31 @@ Tcl_NRCmdSwap(
}
/*****************************************************************************
- * Stuff for tailcalls
+ * Tailcall related code
*****************************************************************************
*
- * Just to show that IT CAN BE DONE! The precise semantics are not simple,
- * require more thought. Possibly need a new Tcl return code to do it right?
- * Questions include:
- * (1) How is the objc/objv tailcall to be run? My current thinking is that
- * it should essentially be
- * [tailcall a b c] <=> [uplevel 1 [list a b c]]
- * with two caveats
- * (a) the current frame is dropped first, after running all pending
- * cleanup tasks and saving its namespace
- * (b) 'a' is looked up in the returning frame's namespace, but the
- * command is run in the context to which we are returning
- * Current implementation does this if [tailcall] is called from within
- * a proc, errors otherwise.
- * (2) Should a tailcall bypass [catch] in the returning frame? Current
- * implementation does not (or does it? Changed, test!) - it causes an
- * error.
- *
- * FIXME NRE!
+ * The steps of the tailcall dance are as follows:
+ *
+ * 1. when [tailcall] is invoked, it stores the corresponding callback in
+ * the current CallFrame and returns TCL_RETURN
+ * 2. when the CallFrame is popped, it calls TclSetTailcall to store the
+ * callback in the proper NRCommand callback - the spot where the command
+ * that pushed the CallFrame is completely cleaned up
+ * 3. when the NRCommand callback runs, it schedules the tailcall callback
+ * to run immediately after it returns
+ *
+ * One delicate point is to properly define the NRCommand where the tailcall
+ * will execute. There are functions whose purpose is to help define the
+ * precise spot:
+ * TclMarkTailcall: if the NEXT command to be pushed tailcalls, execution
+ * should continue right here
+ * TclSkipTailcall: if the NEXT command to be pushed tailcalls, execution
+ * should continue after the CURRENT command is fully returned ("skip
+ * the next command: we are redirecting to it, tailcalls should run
+ * after WE return")
+ * TclPushTailcallPoint: the search for a tailcalling spot cannot traverse
+ * this point. This is special for OO, as some of the oo constructs
+ * that behave like commands may not push an NRCommand callback.
*/
void
@@ -8200,6 +8221,18 @@ TclPushTailcallPoint(
((Interp *) interp)->numLevels++;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetTailcall --
+ *
+ * Splice a tailcall command in the proper spot of the NRE callback
+ * stack, so that it runs at the right time.
+ *
+ *----------------------------------------------------------------------
+ */
+
void
TclSetTailcall(
Tcl_Interp *interp,
@@ -8224,6 +8257,23 @@ TclSetTailcall(
runPtr->data[1] = listPtr;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRTailcallObjCmd --
+ *
+ * Prepare the tailcall as a list and store it in the current
+ * varFrame. When the frame is later popped the tailcall will be spliced
+ * at the proper place.
+ *
+ * Results:
+ * The first NRCommand callback that is not marked to be skipped is
+ * updated so that its data[1] field contains the tailcall list.
+ *
+ *----------------------------------------------------------------------
+ */
+
int
TclNRTailcallObjCmd(
ClientData clientData,
@@ -8238,9 +8288,9 @@ TclNRTailcallObjCmd(
return TCL_ERROR;
}
- if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { /* or is upleveled */
+ if (!(iPtr->varFramePtr->isProcCallFrame & 1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "tailcall can only be called from a proc or lambda", -1));
+ "tailcall can only be called from a proc, lambda or method", -1));
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
return TCL_ERROR;
}
@@ -8258,8 +8308,7 @@ TclNRTailcallObjCmd(
/*
* Create the callback to actually evaluate the tailcalled
* command, then set it in the varFrame so that PopCallFrame can use it
- * at the proper time. Being lazy: exploit the TclNRAddCallBack macro to
- * build the callback.
+ * at the proper time.
*/
if (objc > 1) {
@@ -8269,7 +8318,7 @@ TclNRTailcallObjCmd(
/* The tailcall data is in a Tcl list: the first element is the
* namespace, the rest the command to be tailcalled. */
-
+
listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
@@ -8278,12 +8327,23 @@ TclNRTailcallObjCmd(
Tcl_Panic("Tailcall failed to find the proper namespace");
}
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
-
+
iPtr->varFramePtr->tailcallPtr = listPtr;
}
return TCL_RETURN;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRTailcallEval --
+ *
+ * This NREcallback actually causes the tailcall to be evaluated.
+ *
+ *----------------------------------------------------------------------
+ */
+
int
TclNRTailcallEval(
ClientData data[],
@@ -8296,9 +8356,9 @@ TclNRTailcallEval(
int objc;
Tcl_Obj **objv;
- Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
+ Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
-
+
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
}
@@ -8413,8 +8473,7 @@ TclNRYieldToObjCmd(
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
Tcl_Obj *listPtr, *nsObjPtr;
- Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- Tcl_Namespace *ns1Ptr;
+ Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
@@ -8428,11 +8487,13 @@ TclNRYieldToObjCmd(
return TCL_ERROR;
}
- /*
- * Add the tailcall in the caller env, then just yield.
- *
- * This is essentially code from TclNRTailcallObjCmd
- */
+ if (((Namespace *) nsPtr)->flags & NS_DYING) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto called in deleted namespace", -1));
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+ NULL);
+ return TCL_ERROR;
+ }
/*
* Add the tailcall in the caller env, then just yield.
@@ -8441,15 +8502,9 @@ TclNRYieldToObjCmd(
*/
listPtr = Tcl_NewListObj(objc, objv);
-
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
- if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
- || (nsPtr != ns1Ptr)) {
- Tcl_Panic("yieldto failed to find the proper namespace");
- }
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
-
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
generated by cgit v0.12 at 2024-11-21 18:47:34 (GMT)