ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tcl 8.6.10

Browse Source
This commit is contained in:
Steve Dower
2020-09-24 22:53:56 +01:00
parent 0343d03b22
commit 3bb8e3e086
1005 changed files with 593700 additions and 41637 deletions
Download Patch File Download Diff File Expand all files Collapse all files

433
generic/tclBasic.c
View File

@@ -158,6 +158,7 @@ static Tcl_NRPostProc Dispatch;
static Tcl_ObjCmdProc NRCoroInjectObjCmd;
static Tcl_NRPostProc NRPostInvoke;
static Tcl_ObjCmdProc CoroTypeObjCmd;
MODULE_SCOPE const TclStubs tclStubs;
@@ -234,7 +235,7 @@ static const CmdInfo builtInCmds[] = {
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
{"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
{"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE},
@@ -285,6 +286,9 @@ static const CmdInfo builtInCmds[] = {
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
{"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
{"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
#ifdef TCL_TIMERATE
{"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
{"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
{"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
@@ -454,7 +458,7 @@ Tcl_CreateInterp(void)
const BuiltinFuncDef *builtinFuncPtr;
const OpCmdInfo *opcmdInfoPtr;
const CmdInfo *cmdInfoPtr;
Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr;
Tcl_Namespace *nsPtr;
Tcl_HashEntry *hPtr;
int isNew;
CancelInfo *cancelInfo;
@@ -480,11 +484,13 @@ Tcl_CreateInterp(void)
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
#if defined(_WIN32) && !defined(_WIN64)
if (sizeof(time_t) != 4) {
/*NOTREACHED*/
Tcl_Panic("<time.h> is not compatible with MSVC");
}
#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T)
/* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T
* the result is a binary incompatible with the 'standard' build of
* Tcl: All extensions using Tcl_StatBuf need to be recompiled in
* the same way. Therefore, this is not officially supported.
* In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet)
*/
if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
|| (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
/*NOTREACHED*/
@@ -842,8 +848,22 @@ Tcl_CreateInterp(void)
TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
/* Coroutine monkeybusiness */
Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
NRCoroInjectObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype",
CoroTypeObjCmd, NULL, NULL);
/* Create an unsupported command for timerate */
Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate",
Tcl_TimeRateObjCmd, NULL, NULL);
/* Export unsupported commands */
nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0);
if (nsPtr) {
Tcl_Export(interp, nsPtr, "*", 1);
}
#ifdef USE_DTRACE
/*
@@ -857,8 +877,8 @@ Tcl_CreateInterp(void)
* Register the builtin math functions.
*/
mathfuncNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL);
if (mathfuncNSPtr == NULL) {
nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathfunc", NULL,NULL);
if (nsPtr == NULL) {
Tcl_Panic("Can't create math function namespace");
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
@@ -868,18 +888,18 @@ Tcl_CreateInterp(void)
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
builtinFuncPtr->objCmdProc, builtinFuncPtr->clientData, NULL);
Tcl_Export(interp, mathfuncNSPtr, builtinFuncPtr->name, 0);
Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0);
}
/*
* Register the mathematical "operator" commands. [TIP #174]
*/
mathopNSPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
if (mathopNSPtr == NULL) {
nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("can't create math operator namespace");
}
Tcl_Export(interp, mathopNSPtr, "*", 1);
Tcl_Export(interp, nsPtr, "*", 1);
#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
@@ -2087,22 +2107,24 @@ Tcl_CreateCommand(
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
if (isNew || deleted) {
if (isNew || deleted) {
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
}
}
/*
* An existing command conflicts. Try to delete it...
*/
/* An existing command conflicts. Try to delete it.. */
cmdPtr = Tcl_GetHashValue(hPtr);
/*
* Be careful to preserve
* any existing import links so we can restore them down below. That
* way, you can redefine a command and its import status will remain
* intact.
* Be careful to preserve any existing import links so we can restore
* them down below. That way, you can redefine a command and its
* import status will remain intact.
*/
cmdPtr->refCount++;
@@ -2122,16 +2144,15 @@ Tcl_CreateCommand(
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away
* the new command (if we try to delete it again, we could get
* stuck in an infinite loop).
* If the deletion callback recreated the command, just throw away the
* new command (if we try to delete it again, we could get stuck in an
* infinite loop).
*/
ckfree(Tcl_GetHashValue(hPtr));
}
if (!deleted) {
/*
* Command resolvers (per-interp, per-namespace) might have resolved
* to a command for the given namespace scope with this command not
@@ -2234,74 +2255,94 @@ Tcl_CreateObjCommand(
* name. */
ClientData clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
* this command is deleted. */
)
{
Interp *iPtr = (Interp *) interp;
ImportRef *oldRefPtr = NULL;
Namespace *nsPtr;
Command *cmdPtr;
Tcl_HashEntry *hPtr;
const char *tail;
int isNew = 0, deleted = 0;
ImportedCmdData *dataPtr;
if (iPtr->flags & DELETED) {
/*
* The interpreter is being deleted. Don't create any new commands;
* it's not safe to muck with the interpreter anymore.
*/
return (Tcl_Command) NULL;
}
/*
* Determine where the command should reside. If its name contains
* namespace qualifiers, we put it in the specified namespace;
* otherwise, we always put it in the global namespace.
*/
if (strstr(cmdName, "::") != NULL) {
Namespace *dummy1, *dummy2;
TclGetNamespaceForQualName(interp, cmdName, NULL,
TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
if ((nsPtr == NULL) || (tail == NULL)) {
return (Tcl_Command) NULL;
}
} else {
nsPtr = iPtr->globalNsPtr;
tail = cmdName;
}
return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr,
proc, clientData, deleteProc);
}
Tcl_Command
TclCreateObjCommandInNs (
Tcl_Interp *interp,
const char *cmdName, /* Name of command, without any namespace components */
Tcl_Namespace *namespace, /* The namespace to create the command in */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
ClientData clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
* this command is deleted. */
) {
int deleted = 0, isNew = 0;
Command *cmdPtr;
ImportRef *oldRefPtr = NULL;
ImportedCmdData *dataPtr;
Tcl_HashEntry *hPtr;
Namespace *nsPtr = (Namespace *) namespace;
/*
* If the command name we seek to create already exists, we need to
* delete that first. That can be tricky in the presence of traces.
* Loop until we no longer find an existing command in the way, or
* until we've deleted one command and that didn't finish the job.
*/
while (1) {
/*
* Determine where the command should reside. If its name contains
* namespace qualifiers, we put it in the specified namespace;
* otherwise, we always put it in the global namespace.
*/
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew);
if (strstr(cmdName, "::") != NULL) {
Namespace *dummy1, *dummy2;
TclGetNamespaceForQualName(interp, cmdName, NULL,
TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail);
if ((nsPtr == NULL) || (tail == NULL)) {
return (Tcl_Command) NULL;
}
} else {
nsPtr = iPtr->globalNsPtr;
tail = cmdName;
}
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew);
if (isNew || deleted) {
if (isNew || deleted) {
/*
* isNew - No conflict with existing command.
* deleted - We've already deleted a conflicting command
*/
break;
}
}
/*
* An existing command conflicts. Try to delete it...
*/
/* An existing command conflicts. Try to delete it.. */
cmdPtr = Tcl_GetHashValue(hPtr);
/*
* [***] 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/
* that crash if the bug is fixed.
* However, this buggy behavior is kept under particular circumstances
* to accommodate deployed binaries of the "tclcompiler" program
* <http://sourceforge.net/projects/tclpro/> that crash if the bug is
* fixed.
*/
if (cmdPtr->objProc == TclInvokeStringCommand
@@ -2325,7 +2366,16 @@ Tcl_CreateObjCommand(
cmdPtr->flags |= CMD_REDEF_IN_PROGRESS;
}
/*
* Make sure namespace doesn't get deallocated.
*/
cmdPtr->nsPtr->refCount++;
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
nsPtr = (Namespace *) TclEnsureNamespace(interp,
(Tcl_Namespace *)cmdPtr->nsPtr);
TclNsDecrRefCount(cmdPtr->nsPtr);
if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) {
oldRefPtr = cmdPtr->importRefPtr;
@@ -2334,7 +2384,6 @@ Tcl_CreateObjCommand(
TclCleanupCommandMacro(cmdPtr);
deleted = 1;
}
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away
@@ -2356,7 +2405,7 @@ Tcl_CreateObjCommand(
* commands.
*/
TclInvalidateCmdLiteral(interp, tail, nsPtr);
TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
/*
* The list of command exported from the namespace might have changed.
@@ -2586,10 +2635,6 @@ TclRenameCommand(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
return TCL_ERROR;
}
cmdNsPtr = cmdPtr->nsPtr;
oldFullName = Tcl_NewObj();
Tcl_IncrRefCount(oldFullName);
Tcl_GetCommandFullName(interp, cmd, oldFullName);
/*
* If the new command name is NULL or empty, delete the command. Do this
@@ -2598,10 +2643,14 @@ TclRenameCommand(
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
result = TCL_OK;
goto done;
return TCL_OK;
}
cmdNsPtr = cmdPtr->nsPtr;
oldFullName = Tcl_NewObj();
Tcl_IncrRefCount(oldFullName);
Tcl_GetCommandFullName(interp, cmd, oldFullName);
/*
* Make sure that the destination command does not already exist. The
* rename operation is like creating a command, so we should automatically
@@ -3100,7 +3149,7 @@ Tcl_DeleteCommandFromToken(
/*
* We must delete this command, even though both traces and delete procs
* may try to avoid this (renaming the command etc). Also traces and
* delete procs may try to delete the command themsevles. This flag
* delete procs may try to delete the command themselves. This flag
* declares that a delete is in progress and that recursive deletes should
* be ignored.
*/
@@ -3113,6 +3162,7 @@ Tcl_DeleteCommandFromToken(
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
@@ -4277,15 +4327,22 @@ EvalObjvCore(
reresolve:
assert(cmdPtr == NULL);
if (preCmdPtr) {
/* Caller gave it to us */
/*
* Caller gave it to us.
*/
if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
/* So long as it exists, use it. */
/*
* So long as it exists, use it.
*/
cmdPtr = preCmdPtr;
} else if (flags & TCL_EVAL_NORESOLVE) {
/*
* When it's been deleted, and we're told not to attempt
* resolving it ourselves, all we can do is raise an error.
* When it's been deleted, and we're told not to attempt resolving
* it ourselves, all we can do is raise an error.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to invoke a deleted command"));
Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
@@ -4301,14 +4358,12 @@ EvalObjvCore(
if (enterTracesDone || iPtr->tracePtr
|| (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
Tcl_Obj *commandPtr = TclGetSourceFromFrame(
flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
objc, objv);
Tcl_IncrRefCount(commandPtr);
if (!enterTracesDone) {
int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
objc, objv);
@@ -4316,10 +4371,10 @@ EvalObjvCore(
* Send any exception from enter traces back as an exception
* raised by the traced command.
* TODO: Is this a bug? Letting an execution trace BREAK or
* CONTINUE or RETURN in the place of the traced command?
* Would either converting all exceptions to TCL_ERROR, or
* just swallowing them be better? (Swallowing them has the
* problem of permanently hiding program errors.)
* CONTINUE or RETURN in the place of the traced command? Would
* either converting all exceptions to TCL_ERROR, or just
* swallowing them be better? (Swallowing them has the problem of
* permanently hiding program errors.)
*/
if (code != TCL_OK) {
@@ -4328,9 +4383,8 @@ EvalObjvCore(
}
/*
* If the enter traces made the resolved cmdPtr unusable, go
* back and resolve again, but next time don't run enter
* traces again.
* If the enter traces made the resolved cmdPtr unusable, go back
* and resolve again, but next time don't run enter traces again.
*/
if (cmdPtr == NULL) {
@@ -4341,9 +4395,9 @@ 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.
* 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.
*/
cmdPtr->refCount++;
@@ -4411,8 +4465,6 @@ TclNRRunCallbacks(
* are to be run. */
{
Interp *iPtr = (Interp *) interp;
NRE_callback *callbackPtr;
Tcl_NRPostProc *procPtr;
/*
* If the interpreter has a non-empty string result, the result object is
@@ -4428,9 +4480,14 @@ TclNRRunCallbacks(
(void) Tcl_GetObjResult(interp);
}
/*
* This is the trampoline.
*/
while (TOP_CB(interp) != rootPtr) {
callbackPtr = TOP_CB(interp);
procPtr = callbackPtr->procPtr;
NRE_callback *callbackPtr = TOP_CB(interp);
Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
@@ -6447,8 +6504,8 @@ Tcl_ExprLongObj(
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
/* FALLTHROUGH */
}
/* FALLTHRU */
case TCL_NUMBER_LONG:
case TCL_NUMBER_WIDE:
case TCL_NUMBER_BIG:
@@ -6636,14 +6693,17 @@ TclNRInvoke(
}
cmdPtr = Tcl_GetHashValue(hPtr);
/* Avoid the exception-handling brain damage when numLevels == 0 . */
/*
* Avoid the exception-handling brain damage when numLevels == 0
*/
iPtr->numLevels++;
Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
/*
* Normal command resolution of objv[0] isn't going to find cmdPtr.
* That's the whole point of **hidden** commands. So tell the
* Eval core machinery not to even try (and risk finding something wrong).
* That's the whole point of **hidden** commands. So tell the Eval core
* machinery not to even try (and risk finding something wrong).
*/
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
@@ -7212,7 +7272,7 @@ ExprIsqrtFunc(
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
if (SIGN(&big) == MP_NEG) {
if (big.sign) {
mp_clear(&big);
goto negarg;
}
@@ -7580,7 +7640,19 @@ ExprEntierFunc(
if (type == TCL_NUMBER_DOUBLE) {
d = *((const double *) ptr);
if ((d >= (double)LONG_MAX) || (d <= (double)LONG_MIN)) {
if ((d < (double)LONG_MAX) && (d > (double)LONG_MIN)) {
long result = (long) d;
Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
return TCL_OK;
#ifndef TCL_WIDE_INT_IS_LONG
} else if ((d < (double)LLONG_MAX) && (d > (double)LLONG_MIN)) {
Tcl_WideInt result = (Tcl_WideInt) d;
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result));
return TCL_OK;
#endif
} else {
mp_int big;
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
@@ -7589,11 +7661,6 @@ ExprEntierFunc(
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
long result = (long) d;
Tcl_SetObjResult(interp, Tcl_NewLongObj(result));
return TCL_OK;
}
}
@@ -7702,8 +7769,8 @@ ExprRandFunc(
iPtr->flags |= RAND_SEED_INITIALIZED;
/*
* Take into consideration the thread this interp is running in order
* to insure different seeds in different threads (bug #416643)
* To ensure different seeds in different threads (bug #416643),
* take into consideration the thread this interp is running in.
*/
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
@@ -8018,13 +8085,21 @@ TclDTraceInfo(
Tcl_DictObjGet(NULL, info, *k++, &val);
args[i] = val ? TclGetString(val) : NULL;
}
/* no "proc" -> use "lambda" */
/*
* no "proc" -> use "lambda"
*/
if (!args[2]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[2] = val ? TclGetString(val) : NULL;
}
k++;
/* no "class" -> use "object" */
/*
* no "class" -> use "object"
*/
if (!args[5]) {
Tcl_DictObjGet(NULL, info, *k, &val);
args[5] = val ? TclGetString(val) : NULL;
@@ -8167,6 +8242,22 @@ Tcl_NRCreateCommand(
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
}
Tcl_Command
TclNRCreateCommandInNs (
Tcl_Interp *interp,
const char *cmdName,
Tcl_Namespace *nsPtr,
Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc) {
Command *cmdPtr = (Command *)
TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc);
cmdPtr->nreProc = nreProc;
return (Tcl_Command) cmdPtr;
}
/****************************************************************************
* Stuff for the public api
@@ -8360,18 +8451,14 @@ TclNRTailcallObjCmd(
if (objc > 1) {
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
/* 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);
/*
* The tailcall data is in a Tcl list: the first element is the
* namespace, the rest the command to be tailcalled.
*/
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("Tailcall failed to find the proper namespace");
}
listPtr = Tcl_NewListObj(objc, objv);
TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
iPtr->varFramePtr->tailcallPtr = listPtr;
@@ -8818,6 +8905,75 @@ TclNREvalList(
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
/*
*----------------------------------------------------------------------
*
* CoroTypeObjCmd --
*
* Implementation of [::tcl::unsupported::corotype] command.
*
*----------------------------------------------------------------------
*/
static int
CoroTypeObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Command *cmdPtr;
CoroutineData *corPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "coroName");
return TCL_ERROR;
}
/*
* Look up the coroutine.
*/
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can only get coroutine type of a coroutine", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
/*
* An active coroutine is "active". Can't tell what it might do in the
* future.
*/
corPtr = cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
return TCL_OK;
}
/*
* Inactive coroutines are classified by the (effective) command used to
* suspend them, which matters when you're injecting a probe.
*/
switch (corPtr->nargs) {
case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL:
Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1));
return TCL_OK;
case COROUTINE_ARGUMENTS_ARBITRARY:
Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1));
return TCL_OK;
default:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unknown coroutine type", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", NULL);
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
@@ -8952,9 +9108,9 @@ TclNRCoroutineObjCmd(
{
Command *cmdPtr;
CoroutineData *corPtr;
const char *fullName, *procName;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_DString ds;
const char *procName, *simpleName;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr,
*inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
if (objc < 3) {
@@ -8962,34 +9118,21 @@ TclNRCoroutineObjCmd(
return TCL_ERROR;
}
/*
* FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have
* something in tclUtil.c to find the FQ name.
*/
fullName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, fullName, NULL, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &procName);
procName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, procName, inNsPtr, 0,
&nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
if (nsPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": unknown namespace",
fullName));
procName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL);
return TCL_ERROR;
}
if (procName == NULL) {
if (simpleName == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\": bad procedure name",
fullName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL);
return TCL_ERROR;
}
if ((nsPtr != iPtr->globalNsPtr)
&& (procName != NULL) && (procName[0] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create procedure \"%s\" in non-global namespace with"
" name starting with \":\"", procName));
procName));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL);
return TCL_ERROR;
}
@@ -9001,16 +9144,9 @@ TclNRCoroutineObjCmd(
corPtr = ckalloc(sizeof(CoroutineData));
Tcl_DStringInit(&ds);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
TclDStringAppendLiteral(&ds, "::");
}
Tcl_DStringAppend(&ds, procName, -1);
cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
/*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine);
Tcl_DStringFree(&ds);
cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
(Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
@@ -9071,9 +9207,12 @@ TclNRCoroutineObjCmd(
TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
NULL, NULL, NULL);
/* insure that the command is looked up in the correct namespace */
/*
* Ensure that the command is looked up in the correct namespace.
*/
iPtr->lookupNsPtr = lookupNsPtr;
Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
Tcl_NREvalObj(interp, Tcl_NewListObj(objc - 2, objv + 2), 0);
iPtr->numLevels--;
SAVE_CONTEXT(corPtr->running);