Posted to tcl by cjo at Fri Sep 08 19:29:26 GMT 2017view raw
- diff --git a/generic/tclBasic.c b/generic/tclBasic.c
- index 5a33445..e5b09b8 100644
- --- a/generic/tclBasic.c
- +++ b/generic/tclBasic.c
- @@ -6141,7 +6141,10 @@ TclNREvalObjEx(
- iPtr->varFramePtr = iPtr->rootFramePtr;
- }
- Tcl_IncrRefCount(objPtr);
- - codePtr = TclCompileObj(interp, objPtr, invoker, word);
- + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
- + if (codePtr == NULL) {
- + codePtr = TclCompileObj(interp, objPtr, invoker, word);
- + }
- TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr,
- objPtr, INT2PTR(allowExceptions), NULL);
- diff --git a/generic/tclObj.c b/generic/tclObj.c
- index 6e4011e..9ea55e7 100644
- --- a/generic/tclObj.c
- +++ b/generic/tclObj.c
- @@ -206,6 +206,10 @@ static Tcl_ThreadDataKey pendingObjDataKey;
- * Prototypes for functions defined later in this file:
- */
- +static void FreeHydra(Tcl_Obj *objPtr);
- +static void DupHydra(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
- +static void UpdateStringOfHydra(Tcl_Obj *objPtr);
- +static int SetHydraFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
- static int ParseBoolean(Tcl_Obj *objPtr);
- static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
- static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
- @@ -243,6 +247,26 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
- * implementations.
- */
- +#define MAX_HYDRA_CLIENTS 5
- +static const Tcl_ObjType tclHydraType = {
- + "hydra", /* name */
- + FreeHydra, /* freeIntRepProc */
- + DupHydra, /* dupIntRepProc */
- + UpdateStringOfHydra, /* updateStringProc */
- + SetHydraFromAny /* setFromAnyProc */
- +};
- +
- +#define HydraGetIntRep(objPtr, hydraPtr) \
- + (hydraPtr) = (Hydra *)((objPtr)->internalRep.twoPtrValue.ptr1)
- +
- +typedef struct HydraClient {
- + const Tcl_ObjType *typePtr;
- + Tcl_ObjIntRep internalRep;
- +} HydraClient;
- +typedef struct Hydra {
- + HydraClient client[MAX_HYDRA_CLIENTS];
- +} Hydra;
- +
- static const Tcl_ObjType oldBooleanType = {
- "boolean", /* name */
- NULL, /* freeIntRepProc */
- @@ -1694,6 +1718,122 @@ Tcl_GetStringFromObj(
- return objPtr->bytes;
- }
- +static void
- +FreeHydra(
- + Tcl_Obj *objPtr)
- +{
- + int i;
- + Hydra *hydraPtr;
- + Tcl_Obj fakeObj;
- +
- + memset(&fakeObj, 0, sizeof(fakeObj));
- + HydraGetIntRep(objPtr, hydraPtr);
- +
- + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
- + if (hydraPtr->client[i].typePtr) {
- + fakeObj.internalRep = hydraPtr->client[i].internalRep;
- + fakeObj.typePtr = hydraPtr->client[i].typePtr;
- + Tcl_FreeIntRep(&fakeObj);
- + if (fakeObj.refCount > 0) {
- + Tcl_Panic("Invalid reference taken to fakeObj while "
- + "freeing intrep for %s",
- + hydraPtr->client[i].typePtr->name);
- + }
- +
- + hydraPtr->client[i].typePtr = NULL;
- + memset(&hydraPtr->client[i].internalRep, 0, sizeof(hydraPtr->client[i].internalRep));
- + }
- + }
- +
- + Tcl_Free((char *)hydraPtr);
- + hydraPtr = objPtr->internalRep.twoPtrValue.ptr1 = NULL;
- +}
- +
- +static void
- +DupHydra(
- + Tcl_Obj *srcPtr,
- + Tcl_Obj *copyPtr)
- +{
- + if (!Tcl_HasStringRep(srcPtr)) {
- + UpdateStringOfHydra(srcPtr);
- + }
- + /* Ensure that duplicates of hydras are pure strings, since the most likely
- + * situation is that we're being duplicated in order to modify the value,
- + * which would invalidate the cached intreps */
- + return;
- +}
- +
- +static void
- +UpdateStringOfHydra(
- + Tcl_Obj *objPtr)
- +{
- + int i;
- + Hydra *hydraPtr;
- + Tcl_Obj fakeObj;
- +
- + memset(&fakeObj, 0, sizeof(fakeObj));
- +
- + HydraGetIntRep(objPtr, hydraPtr);
- +
- + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
- + HydraClient *clientPtr = &hydraPtr->client[i];
- +
- + if (clientPtr->typePtr) {
- + if (clientPtr->typePtr->updateStringProc) {
- + fakeObj.internalRep = hydraPtr->client[i].internalRep;
- + fakeObj.typePtr = hydraPtr->client[i].typePtr;
- + /* Don't know if this is necessary */
- + fakeObj.bytes = NULL;
- + fakeObj.length = 0;
- +
- + fakeObj.typePtr->updateStringProc(&fakeObj);
- +
- + if (fakeObj.refCount > 0) {
- + Tcl_Panic("Invalid reference taken to fakeObj while "
- + "updating string rep using %s",
- + hydraPtr->client[i].typePtr->name);
- + }
- +
- + if (TclHasStringRep(&fakeObj)) { /* Not sure about this */
- + objPtr->bytes = fakeObj.bytes;
- + objPtr->length = fakeObj.length;
- + fakeObj.bytes = NULL;
- + fakeObj.length = 0;
- + return;
- + }
- + }
- + }
- + }
- +
- + /* TODO: what? */
- + Tcl_Panic("Could not update string rep of hydra: %s",
- + "No clients capable of regenerating string rep found");
- +}
- +
- +static int
- +SetHydraFromAny(
- + Tcl_Interp *interp,
- + Tcl_Obj *objPtr)
- +{
- + Hydra *hydraPtr;
- +
- + if (objPtr->typePtr == &tclHydraType) {
- + return TCL_OK;
- + }
- +
- + hydraPtr = (Hydra *)Tcl_Alloc(sizeof(Hydra));
- + memset(hydraPtr, 0, sizeof(Hydra));
- +
- + hydraPtr->client[0].typePtr = objPtr->typePtr;
- + hydraPtr->client[0].internalRep = objPtr->internalRep;
- +
- + objPtr->internalRep.twoPtrValue.ptr1 = hydraPtr;
- + objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- + objPtr->typePtr = &tclHydraType;
- +
- + return TCL_OK;
- +}
- +
- /*
- *----------------------------------------------------------------------
- *
- @@ -1852,16 +1992,104 @@ Tcl_StoreIntRep(
- const Tcl_ObjType *typePtr, /* New type for the object */
- const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */
- {
- - /* Clear out any existing IntRep ( "shimmer" ) */
- - TclFreeIntRep(objPtr);
- + int i;
- + Hydra *hydraPtr;
- - /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */
- - if (irPtr) {
- - /* Copy the new IntRep into place */
- + if (objPtr->typePtr == NULL) {
- + /* Special case - updating (or clearing) a pure string object */
- + TclFreeIntRep(objPtr);
- objPtr->internalRep = *irPtr;
- -
- - /* Set the type to match */
- objPtr->typePtr = typePtr;
- + return;
- + }
- +
- + if (objPtr->typePtr == typePtr) {
- + /* Special case - updating (or clearing) an objects existing intrep */
- + TclFreeIntRep(objPtr);
- + objPtr->internalRep = *irPtr;
- + return;
- + }
- +
- + if (objPtr->typePtr != &tclHydraType) {
- + SetHydraFromAny(NULL, objPtr);
- + }
- +
- + HydraGetIntRep(objPtr, hydraPtr);
- +
- + if (irPtr) {
- + int firstAvailableSlot = -1;
- +
- + /* If we have an existing client with a matching type, we need to
- + * update that intrep even if there is an open slot before it */
- + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
- + HydraClient *clientPtr = &hydraPtr->client[i];
- +
- + if (clientPtr->typePtr == typePtr) {
- + Tcl_Obj fakeObj;
- +
- + /* Free the matching client intrep, using a fake obj */
- + memset(&fakeObj, 0, sizeof(fakeObj));
- + fakeObj.typePtr = typePtr;
- + fakeObj.internalRep = clientPtr->internalRep;
- + //Tcl_InvalidateStringRep(&fakeObj);
- + TclFreeIntRep(&fakeObj);
- +
- + if (fakeObj.refCount > 0) {
- + Tcl_Panic("Invalid reference taken to fakeObj while "
- + "freeing hydra client interp for %s",
- + typePtr->name);
- + }
- +
- + /* Update the intrep */
- + clientPtr->internalRep = *irPtr;
- + return;
- + } else if (firstAvailableSlot == -1 && clientPtr->typePtr == NULL) {
- + /* Record the first available slot in case we need to add this
- + * intrep there */
- + firstAvailableSlot = i;
- + }
- + }
- +
- + if (firstAvailableSlot > -1) {
- + HydraClient *clientPtr = &hydraPtr->client[firstAvailableSlot];
- +
- + if (clientPtr->typePtr == NULL) {
- + /* Found available slot, put this intrep there */
- + clientPtr->internalRep = *irPtr;
- + clientPtr->typePtr = typePtr;
- + return;
- + }
- + }
- +
- + /* No available client slots. Upconvert to linked list? */
- + Tcl_Panic("Unable to add client intrep for %s to hydra: "
- + "No slots available", typePtr->name);
- + } else {
- + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
- + HydraClient *clientPtr = &hydraPtr->client[i];
- +
- + if (clientPtr->typePtr == typePtr) {
- + Tcl_Obj fakeObj;
- +
- + /* Free the matching client intrep, using a fake obj */
- + memset(&fakeObj, 0, sizeof(fakeObj));
- + fakeObj.typePtr = typePtr;
- + fakeObj.internalRep = clientPtr->internalRep;
- + //Tcl_InvalidateStringRep(&fakeObj);
- + TclFreeIntRep(&fakeObj);
- +
- + if (fakeObj.refCount > 0) {
- + Tcl_Panic("Invalid reference taken to fakeObj while "
- + "freeing hydra client interp for %s",
- + typePtr->name);
- + }
- +
- + /* Mark the client slot as available */
- + clientPtr->typePtr = NULL;
- + memset(&clientPtr->internalRep, 0, sizeof(clientPtr->internalRep));
- + return;
- + }
- + }
- }
- }
- @@ -1878,8 +2106,7 @@ Tcl_StoreIntRep(
- * NULL if no such internal representation exists.
- *
- * Side effects:
- - * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
- - * Sets the internalRep and typePtr fields to the submitted values.
- + * None.
- *
- *----------------------------------------------------------------------
- */
- @@ -1889,13 +2116,27 @@ Tcl_FetchIntRep(
- Tcl_Obj *objPtr, /* Object to fetch from. */
- const Tcl_ObjType *typePtr) /* Requested type */
- {
- - /* If objPtr type doesn't match request, nothing can be fetched */
- - if (objPtr->typePtr != typePtr) {
- - return NULL;
- + if (objPtr->typePtr == typePtr) {
- + /* Type match! objPtr IntRep is the one sought. */
- + return &(objPtr->internalRep);
- + }
- +
- + if (objPtr->typePtr == &tclHydraType) {
- + int i;
- + Hydra *hydraPtr;
- +
- + HydraGetIntRep(objPtr, hydraPtr);
- +
- + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
- + HydraClient *clientPtr = &hydraPtr->client[i];
- +
- + if (clientPtr->typePtr == typePtr) {
- + return &(clientPtr->internalRep);
- + }
- + }
- }
- - /* Type match! objPtr IntRep is the one sought. */
- - return &(objPtr->internalRep);
- + return NULL;
- }
- /*
- @@ -4694,6 +4935,32 @@ Tcl_RepresentationCmd(
- Tcl_AppendToObj(descObj, ", no string representation", -1);
- }
- + if (objv[1]->typePtr == &tclHydraType) {
- + int i;
- + Hydra *hydraPtr;
- +
- + Tcl_AppendToObj(descObj, ", with client representations:", -1);
- + HydraGetIntRep(objv[1], hydraPtr);
- + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
- + HydraClient *clientPtr = &hydraPtr->client[i];
- +
- + if (clientPtr->typePtr == NULL) {
- + continue;
- + }
- +
- + Tcl_AppendPrintfToObj(descObj, "\n\t%d: %s", i, clientPtr->typePtr->name);
- +
- + if (clientPtr->typePtr == &tclDoubleType) {
- + Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
- + clientPtr->internalRep.doubleValue);
- + } else {
- + Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
- + (void *) clientPtr->internalRep.twoPtrValue.ptr1,
- + (void *) clientPtr->internalRep.twoPtrValue.ptr2);
- + }
- + }
- + }
- +
- Tcl_SetObjResult(interp, descObj);
- return TCL_OK;
- }