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

Import Tcl-code 8.6.8

Browse Source
This commit is contained in:
Cheryl Sabella
2018-02-22 14:28:00 -05:00
parent 261a0e7c44
commit cc7c413b4f
509 changed files with 18473 additions and 18499 deletions
Download Patch File Download Diff File Expand all files Collapse all files

168
generic/tclTest.c
View File

@@ -331,12 +331,10 @@ static int TestreturnObjCmd(ClientData dummy,
Tcl_Obj *const objv[]);
static void TestregexpXflags(const char *string,
int length, int *cflagsPtr, int *eflagsPtr);
#ifndef TCL_NO_DEPRECATED
static int TestsaveresultCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void TestsaveresultFree(char *blockPtr);
#endif /* TCL_NO_DEPRECATED */
static int TestsetassocdataCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetCmd(ClientData dummy,
@@ -409,6 +407,12 @@ static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
static int TestNumUtfCharsCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestFindFirstCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestFindLastCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestHashSystemHashCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -534,9 +538,7 @@ int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
#ifndef TCL_NO_DEPRECATED
Tcl_ValueType t3ArgTypes[2];
#endif /* TCL_NO_DEPRECATED */
Tcl_Obj *listPtr;
Tcl_Obj **objv;
@@ -656,10 +658,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
#ifndef TCL_NO_DEPRECATED
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
@@ -674,6 +674,10 @@ Tcltest_Init(
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
@@ -681,10 +685,8 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
#ifndef TCL_NO_DEPRECATED
Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
@@ -695,12 +697,10 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
(ClientData) 0, NULL);
#endif
#ifndef TCL_NO_DEPRECATED
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
NULL);
#endif /* TCL_NO_DEPRECATED */
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
@@ -4570,7 +4570,7 @@ TestpanicCmd(
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
const char *argString;
char *argString;
/*
* Put the arguments into a var args structure
@@ -5075,7 +5075,6 @@ Testset2Cmd(
}
}
#ifndef TCL_NO_DEPRECATED
/*
*----------------------------------------------------------------------
*
@@ -5209,7 +5208,6 @@ TestsaveresultFree(
{
freeCount++;
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6684,7 +6682,7 @@ TestNumUtfCharsCmd(
int len = -1;
if (objc > 2) {
(void) Tcl_GetStringFromObj(objv[1], &len);
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
@@ -6692,6 +6690,50 @@ TestNumUtfCharsCmd(
return TCL_OK;
}
/*
* Used to check correct operation of Tcl_UtfFindFirst
*/
static int
TestFindFirstCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1));
}
return TCL_OK;
}
/*
* Used to check correct operation of Tcl_UtfFindLast
*/
static int
TestFindLastCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1));
}
return TCL_OK;
}
#if defined(HAVE_CPUID) || defined(_WIN32)
/*
*----------------------------------------------------------------------
@@ -7299,23 +7341,82 @@ InterpCmdResolver(
CallFrame *varFramePtr = iPtr->varFramePtr;
Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
varFramePtr->procPtr : NULL;
Namespace *ns2NsPtr = (Namespace *)
Tcl_FindNamespace(interp, "::ns2", NULL, 0);
Namespace *callerNsPtr = varFramePtr->nsPtr;
Tcl_Command resolvedCmdPtr = NULL;
if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
|| (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
const char *callingCmdName =
/*
* Just do something special on a cmd literal "z" in two cases:
* A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2".
* B) the caller's namespace is "ctx1" or "ctx2"
*/
if ( (name[0] == 'z') && (name[1] == '\0') ) {
Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0);
if (procPtr != NULL
&& ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr)
|| (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr)
)
) {
/*
* Case A)
*
* - The context, in which this resolver becomes active, is
* determined by the name of the caller proc, which has to be
* named "x".
*
* - To determine the name of the caller proc, the proc is taken
* from the topmost stack frame.
*
* - Note that the context is NOT provided during byte-code
* compilation (e.g. in TclProcCompileProc)
*
* When these conditions hold, this function resolves the
* passed-in cmd literal into a cmd "y", which is taken from the
* the global namespace (for simplicity).
*/
const char *callingCmdName =
Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
&& (name[0] == 'z') && (name[1] == '\0')) {
Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
TCL_GLOBAL_ONLY);
if (sourceCmdPtr != NULL) {
*rPtr = sourceCmdPtr;
return TCL_OK;
if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
}
} else if (callerNsPtr != NULL) {
/*
* Case B)
*
* - The context, in which this resolver becomes active, is
* determined by the name of the parent namespace, which has
* to be named "ctx1" or "ctx2".
*
* - To determine the name of the parent namesace, it is taken
* from the 2nd highest stack frame.
*
* - Note that the context can be provided during byte-code
* compilation (e.g. in TclProcCompileProc)
*
* When these conditions hold, this function resolves the
* passed-in cmd literal into a cmd "y" or "Y" depending on the
* context. The resolved procs are taken from the the global
* namespace (for simplicity).
*/
CallFrame *parentFramePtr = varFramePtr->callerPtr;
char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
/* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/
} else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY);
/*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/
}
}
if (resolvedCmdPtr != NULL) {
*rPtr = resolvedCmdPtr;
return TCL_OK;
}
}
return TCL_CONTINUE;
@@ -7449,9 +7550,16 @@ TestInterpResolverCmd(
int idx;
#define RESOLVER_KEY "testInterpResolver"
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "up|down");
return TCL_ERROR;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
return TCL_ERROR;
}
if (objc == 3) {
interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
if (interp == NULL) {
Tcl_AppendResult(interp, "provided interpreter not found", NULL);
return TCL_ERROR;
}
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {