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

301
generic/tclVar.c
View File

@@ -1309,7 +1309,7 @@ Tcl_ObjGetVar2(
return NULL;
}
return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
return TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
flags, -1);
}
@@ -1337,6 +1337,52 @@ Tcl_ObjGetVar2(
Tcl_Obj *
TclPtrGetVar(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Tcl_Var varPtr, /* The variable to be read.*/
Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
if (part1Ptr == NULL) {
Tcl_Panic("part1Ptr must not be NULL");
}
return TclPtrGetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
part1Ptr, part2Ptr, flags, -1);
}
/*
*----------------------------------------------------------------------
*
* TclPtrGetVarIdx --
*
* Return the value of a Tcl variable as a Tcl object, given the pointers
* to the variable's (and possibly containing array's) VAR structure.
*
* Results:
* The return value points to the current object value of the variable
* given by varPtr. If the specified variable doesn't exist, or if there
* is a clash in array usage, then NULL is returned and a message will be
* left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to reflect
* the returned reference; if you want to keep a reference to the object
* you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrGetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
register Var *varPtr, /* The variable to be read.*/
@@ -1678,7 +1724,7 @@ Tcl_ObjSetVar2(
return NULL;
}
return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
newValuePtr, flags, -1);
}
@@ -1709,6 +1755,60 @@ Tcl_ObjSetVar2(
Tcl_Obj *
TclPtrSetVar(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Tcl_Var varPtr, /* Reference to the variable to set. */
Tcl_Var arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
* scalar. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr, /* New value for variable. */
const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
if (part1Ptr == NULL) {
Tcl_Panic("part1Ptr must not be NULL");
}
if (newValuePtr == NULL) {
Tcl_Panic("newValuePtr must not be NULL");
}
return TclPtrSetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
part1Ptr, part2Ptr, newValuePtr, flags, -1);
}
/*
*----------------------------------------------------------------------
*
* TclPtrSetVarIdx --
*
* This function is the same as Tcl_SetVar2Ex above, except that it
* requires pointers to the variable's Var structs in addition to the
* variable names.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the write operation was disallowed because an array was
* expected but not found (or vice versa), then NULL is returned; if the
* TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be
* left in the interpreter's result. Note that the returned object may
* not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrSetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
register Var *varPtr, /* Reference to the variable to set. */
@@ -1953,7 +2053,7 @@ TclIncrObjVar2(
"\n (reading value of variable to increment)");
return NULL;
}
return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
return TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
incrPtr, flags, -1);
}
@@ -1984,6 +2084,62 @@ TclIncrObjVar2(
Tcl_Obj *
TclPtrIncrObjVar(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
Tcl_Var varPtr, /* Reference to the variable to set. */
Tcl_Var arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
* scalar. */
Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *incrPtr, /* Increment value. */
/* TODO: Which of these flag values really make sense? */
const int flags) /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
if (part1Ptr == NULL) {
Tcl_Panic("part1Ptr must not be NULL");
}
return TclPtrIncrObjVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
part1Ptr, part2Ptr, incrPtr, flags, -1);
}
/*
*----------------------------------------------------------------------
*
* TclPtrIncrObjVarIdx --
*
* Given the pointers to a variable and possible containing array,
* increment the Tcl object value of the variable by a Tcl_Obj increment.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the specified variable doesn't exist, or there is a clash
* in array usage, or an error occurs while executing variable traces,
* then NULL is returned and a message will be left in the interpreter's
* result.
*
* Side effects:
* The value of the given variable is incremented by the specified
* amount. If either the array or the entry didn't exist then a new
* variable is created. The ref count for the returned object is _not_
* incremented to reflect the returned reference; if you want to keep a
* reference to the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrIncrObjVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
Var *varPtr, /* Reference to the variable to set. */
@@ -2011,8 +2167,8 @@ TclPtrIncrObjVar(
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
}
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
flags, index);
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
@@ -2024,8 +2180,8 @@ TclPtrIncrObjVar(
varValuePtr = Tcl_DuplicateObj(varValuePtr);
if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
varValuePtr, flags, index);
return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, varValuePtr, flags, index);
} else {
Tcl_DecrRefCount(varValuePtr);
return NULL;
@@ -2041,8 +2197,8 @@ TclPtrIncrObjVar(
* is the way to make that happen.
*/
return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
varValuePtr, flags, index);
return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, varValuePtr, flags, index);
} else {
return NULL;
}
@@ -2189,8 +2345,8 @@ TclObjUnsetVar2(
return TCL_ERROR;
}
return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags,
-1);
return TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
flags, -1);
}
/*
@@ -2217,6 +2373,53 @@ TclObjUnsetVar2(
int
TclPtrUnsetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
Tcl_Var varPtr, /* The variable to be unset. */
Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
const int flags) /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
if (varPtr == NULL) {
Tcl_Panic("varPtr must not be NULL");
}
if (part1Ptr == NULL) {
Tcl_Panic("part1Ptr must not be NULL");
}
return TclPtrUnsetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
part1Ptr, part2Ptr, flags, -1);
}
/*
*----------------------------------------------------------------------
*
* TclPtrUnsetVarIdx --
*
* Delete a variable, given the pointers to the variable's (and possibly
* containing array's) VAR structure.
*
* Results:
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
* the variable can't be unset. In the event of an error, if the
* TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
* interp's result.
*
* Side effects:
* If varPtr and arrayPtr indicate a local or global variable in interp,
* it is deleted. If varPtr is an array reference and part2Ptr is NULL,
* then the whole array is deleted.
*
*----------------------------------------------------------------------
*/
int
TclPtrUnsetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
register Var *varPtr, /* The variable to be unset. */
@@ -2566,11 +2769,11 @@ Tcl_AppendObjCmd(
/*
* Note that we do not need to increase the refCount of the Var
* pointers: should a trace delete the variable, the return value
* of TclPtrSetVar will be NULL or emptyObjPtr, and we will not
* of TclPtrSetVarIdx will be NULL or emptyObjPtr, and we will not
* access the variable again.
*/
varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1],
varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1],
NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1);
if ((varValuePtr == NULL) ||
(varValuePtr == ((Interp *) interp)->emptyObjPtr)) {
@@ -2650,7 +2853,7 @@ Tcl_LappendObjCmd(
createdNewObj = 0;
/*
* Protect the variable pointers around the TclPtrGetVar call
* Protect the variable pointers around the TclPtrGetVarIdx call
* to insure that they remain valid even if the variable was undefined
* and unused.
*/
@@ -2666,7 +2869,7 @@ Tcl_LappendObjCmd(
if (arrayPtr && TclIsVarInHash(arrayPtr)) {
VarHashRefCount(arrayPtr)++;
}
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, objv[1], NULL,
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL,
TCL_LEAVE_ERR_MSG, -1);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
@@ -2707,7 +2910,7 @@ Tcl_LappendObjCmd(
* and we didn't create the variable.
*/
newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL,
newValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL,
varValuePtr, TCL_LEAVE_ERR_MSG, -1);
if (newValuePtr == NULL) {
return TCL_ERROR;
@@ -2808,7 +3011,7 @@ TclArraySet(
keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
(TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
(TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
Tcl_DictObjDone(&search);
return TCL_ERROR;
@@ -2818,7 +3021,7 @@ TclArraySet(
} else {
/*
* Not a dictionary, so assume (and convert to, for backward-
* -compatability reasons) a list.
* -compatibility reasons) a list.
*/
int elemLen;
@@ -2841,8 +3044,8 @@ TclArraySet(
/*
* We needn't worry about traces invalidating arrayPtr: should that be
* the case, TclPtrSetVar will return NULL so that we break out of the
* loop and return an error.
* the case, TclPtrSetVarIdx will return NULL so that we break out of
* the loop and return an error.
*/
copyListObj = TclListObjCopy(NULL, arrayElemObj);
@@ -2851,7 +3054,7 @@ TclArraySet(
elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
(TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
(TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
result = TCL_ERROR;
break;
@@ -4078,8 +4281,8 @@ ArrayUnsetCmd(
if (!varPtr2 || TclIsVarUndefined(varPtr2)) {
return TCL_OK;
}
return TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, patternObj,
unsetFlags, -1);
return TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj,
patternObj, unsetFlags, -1);
}
/*
@@ -4127,7 +4330,7 @@ ArrayUnsetCmd(
nameObj = VarHashGetKey(varPtr2);
if (Tcl_StringMatch(TclGetString(nameObj), pattern)
&& TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj,
&& TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj,
nameObj, unsetFlags, -1) != TCL_OK) {
/*
* If we incremented a refcount, we must decrement it here as we
@@ -4274,7 +4477,7 @@ ObjMakeUpvar(
}
}
return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
return TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, index);
}
/*
@@ -4316,17 +4519,32 @@ TclPtrMakeUpvar(
myNamePtr = Tcl_NewStringObj(myName, -1);
Tcl_IncrRefCount(myNamePtr);
}
result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
result = TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags,
index);
if (myNamePtr) {
Tcl_DecrRefCount(myNamePtr);
}
return result;
}
int
TclPtrObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
* error messages, too. */
Tcl_Var otherPtr, /* Pointer to the variable being linked-to. */
Tcl_Obj *myNamePtr, /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
int myFlags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
{
return TclPtrObjMakeUpvarIdx(interp, (Var *) otherPtr, myNamePtr, myFlags,
-1);
}
/* Callers must Incr myNamePtr if they plan to Decr it. */
int
TclPtrObjMakeUpvar(
TclPtrObjMakeUpvarIdx(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
* error messages, too. */
Var *otherPtr, /* Pointer to the variable being linked-to. */
@@ -4793,8 +5011,9 @@ Tcl_VariableObjCmd(
*/
if (i+1 < objc) { /* A value was specified. */
varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varNamePtr,
NULL, objv[i+1], TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG,-1);
varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr,
varNamePtr, NULL, objv[i+1],
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), -1);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
@@ -5193,13 +5412,16 @@ TclDeleteNamespaceVars(
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, NULL, flags,
-1);
Tcl_DecrRefCount(objPtr); /* Free no longer needed obj */
UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
NULL, flags, -1);
/*
* Remove the variable from the table and force it undefined in case
* an unset trace brought it back from the dead.
* We just unset the variable. However, an unset trace might
* have re-set it, or might have re-established traces on it.
* This namespace and its vartable are going away unconditionally,
* so we cannot let such things linger. That would be a leak.
*
* First we destroy all traces. ...
*/
if (TclIsVarTraced(varPtr)) {
@@ -5223,6 +5445,17 @@ TclDeleteNamespaceVars(
}
}
}
/*
* ...and then, if the variable still holds a value, we unset it
* again. This time with no traces left, we're sure it goes away.
*/
if (!TclIsVarUndefined(varPtr)) {
UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
NULL, flags, -1);
}
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
VarHashRefCount(varPtr)--;
VarHashDeleteEntry(varPtr);
}