Posted to tcl by cjo at Fri Sep 08 19:29:26 GMT 2017view raw

  1. diff --git a/generic/tclBasic.c b/generic/tclBasic.c
  2. index 5a33445..e5b09b8 100644
  3. --- a/generic/tclBasic.c
  4. +++ b/generic/tclBasic.c
  5. @@ -6141,7 +6141,10 @@ TclNREvalObjEx(
  6. iPtr->varFramePtr = iPtr->rootFramePtr;
  7. }
  8. Tcl_IncrRefCount(objPtr);
  9. - codePtr = TclCompileObj(interp, objPtr, invoker, word);
  10. + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
  11. + if (codePtr == NULL) {
  12. + codePtr = TclCompileObj(interp, objPtr, invoker, word);
  13. + }
  14.  
  15. TclNRAddCallback(interp, TEOEx_ByteCodeCallback, savedVarFramePtr,
  16. objPtr, INT2PTR(allowExceptions), NULL);
  17. diff --git a/generic/tclObj.c b/generic/tclObj.c
  18. index 6e4011e..9ea55e7 100644
  19. --- a/generic/tclObj.c
  20. +++ b/generic/tclObj.c
  21. @@ -206,6 +206,10 @@ static Tcl_ThreadDataKey pendingObjDataKey;
  22. * Prototypes for functions defined later in this file:
  23. */
  24.  
  25. +static void FreeHydra(Tcl_Obj *objPtr);
  26. +static void DupHydra(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
  27. +static void UpdateStringOfHydra(Tcl_Obj *objPtr);
  28. +static int SetHydraFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
  29. static int ParseBoolean(Tcl_Obj *objPtr);
  30. static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
  31. static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
  32. @@ -243,6 +247,26 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
  33. * implementations.
  34. */
  35.  
  36. +#define MAX_HYDRA_CLIENTS 5
  37. +static const Tcl_ObjType tclHydraType = {
  38. + "hydra", /* name */
  39. + FreeHydra, /* freeIntRepProc */
  40. + DupHydra, /* dupIntRepProc */
  41. + UpdateStringOfHydra, /* updateStringProc */
  42. + SetHydraFromAny /* setFromAnyProc */
  43. +};
  44. +
  45. +#define HydraGetIntRep(objPtr, hydraPtr) \
  46. + (hydraPtr) = (Hydra *)((objPtr)->internalRep.twoPtrValue.ptr1)
  47. +
  48. +typedef struct HydraClient {
  49. + const Tcl_ObjType *typePtr;
  50. + Tcl_ObjIntRep internalRep;
  51. +} HydraClient;
  52. +typedef struct Hydra {
  53. + HydraClient client[MAX_HYDRA_CLIENTS];
  54. +} Hydra;
  55. +
  56. static const Tcl_ObjType oldBooleanType = {
  57. "boolean", /* name */
  58. NULL, /* freeIntRepProc */
  59. @@ -1694,6 +1718,122 @@ Tcl_GetStringFromObj(
  60. return objPtr->bytes;
  61. }
  62.  
  63. +static void
  64. +FreeHydra(
  65. + Tcl_Obj *objPtr)
  66. +{
  67. + int i;
  68. + Hydra *hydraPtr;
  69. + Tcl_Obj fakeObj;
  70. +
  71. + memset(&fakeObj, 0, sizeof(fakeObj));
  72. + HydraGetIntRep(objPtr, hydraPtr);
  73. +
  74. + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
  75. + if (hydraPtr->client[i].typePtr) {
  76. + fakeObj.internalRep = hydraPtr->client[i].internalRep;
  77. + fakeObj.typePtr = hydraPtr->client[i].typePtr;
  78. + Tcl_FreeIntRep(&fakeObj);
  79. + if (fakeObj.refCount > 0) {
  80. + Tcl_Panic("Invalid reference taken to fakeObj while "
  81. + "freeing intrep for %s",
  82. + hydraPtr->client[i].typePtr->name);
  83. + }
  84. +
  85. + hydraPtr->client[i].typePtr = NULL;
  86. + memset(&hydraPtr->client[i].internalRep, 0, sizeof(hydraPtr->client[i].internalRep));
  87. + }
  88. + }
  89. +
  90. + Tcl_Free((char *)hydraPtr);
  91. + hydraPtr = objPtr->internalRep.twoPtrValue.ptr1 = NULL;
  92. +}
  93. +
  94. +static void
  95. +DupHydra(
  96. + Tcl_Obj *srcPtr,
  97. + Tcl_Obj *copyPtr)
  98. +{
  99. + if (!Tcl_HasStringRep(srcPtr)) {
  100. + UpdateStringOfHydra(srcPtr);
  101. + }
  102. + /* Ensure that duplicates of hydras are pure strings, since the most likely
  103. + * situation is that we're being duplicated in order to modify the value,
  104. + * which would invalidate the cached intreps */
  105. + return;
  106. +}
  107. +
  108. +static void
  109. +UpdateStringOfHydra(
  110. + Tcl_Obj *objPtr)
  111. +{
  112. + int i;
  113. + Hydra *hydraPtr;
  114. + Tcl_Obj fakeObj;
  115. +
  116. + memset(&fakeObj, 0, sizeof(fakeObj));
  117. +
  118. + HydraGetIntRep(objPtr, hydraPtr);
  119. +
  120. + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
  121. + HydraClient *clientPtr = &hydraPtr->client[i];
  122. +
  123. + if (clientPtr->typePtr) {
  124. + if (clientPtr->typePtr->updateStringProc) {
  125. + fakeObj.internalRep = hydraPtr->client[i].internalRep;
  126. + fakeObj.typePtr = hydraPtr->client[i].typePtr;
  127. + /* Don't know if this is necessary */
  128. + fakeObj.bytes = NULL;
  129. + fakeObj.length = 0;
  130. +
  131. + fakeObj.typePtr->updateStringProc(&fakeObj);
  132. +
  133. + if (fakeObj.refCount > 0) {
  134. + Tcl_Panic("Invalid reference taken to fakeObj while "
  135. + "updating string rep using %s",
  136. + hydraPtr->client[i].typePtr->name);
  137. + }
  138. +
  139. + if (TclHasStringRep(&fakeObj)) { /* Not sure about this */
  140. + objPtr->bytes = fakeObj.bytes;
  141. + objPtr->length = fakeObj.length;
  142. + fakeObj.bytes = NULL;
  143. + fakeObj.length = 0;
  144. + return;
  145. + }
  146. + }
  147. + }
  148. + }
  149. +
  150. + /* TODO: what? */
  151. + Tcl_Panic("Could not update string rep of hydra: %s",
  152. + "No clients capable of regenerating string rep found");
  153. +}
  154. +
  155. +static int
  156. +SetHydraFromAny(
  157. + Tcl_Interp *interp,
  158. + Tcl_Obj *objPtr)
  159. +{
  160. + Hydra *hydraPtr;
  161. +
  162. + if (objPtr->typePtr == &tclHydraType) {
  163. + return TCL_OK;
  164. + }
  165. +
  166. + hydraPtr = (Hydra *)Tcl_Alloc(sizeof(Hydra));
  167. + memset(hydraPtr, 0, sizeof(Hydra));
  168. +
  169. + hydraPtr->client[0].typePtr = objPtr->typePtr;
  170. + hydraPtr->client[0].internalRep = objPtr->internalRep;
  171. +
  172. + objPtr->internalRep.twoPtrValue.ptr1 = hydraPtr;
  173. + objPtr->internalRep.twoPtrValue.ptr2 = NULL;
  174. + objPtr->typePtr = &tclHydraType;
  175. +
  176. + return TCL_OK;
  177. +}
  178. +
  179. /*
  180. *----------------------------------------------------------------------
  181. *
  182. @@ -1852,16 +1992,104 @@ Tcl_StoreIntRep(
  183. const Tcl_ObjType *typePtr, /* New type for the object */
  184. const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */
  185. {
  186. - /* Clear out any existing IntRep ( "shimmer" ) */
  187. - TclFreeIntRep(objPtr);
  188. + int i;
  189. + Hydra *hydraPtr;
  190.  
  191. - /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */
  192. - if (irPtr) {
  193. - /* Copy the new IntRep into place */
  194. + if (objPtr->typePtr == NULL) {
  195. + /* Special case - updating (or clearing) a pure string object */
  196. + TclFreeIntRep(objPtr);
  197. objPtr->internalRep = *irPtr;
  198. -
  199. - /* Set the type to match */
  200. objPtr->typePtr = typePtr;
  201. + return;
  202. + }
  203. +
  204. + if (objPtr->typePtr == typePtr) {
  205. + /* Special case - updating (or clearing) an objects existing intrep */
  206. + TclFreeIntRep(objPtr);
  207. + objPtr->internalRep = *irPtr;
  208. + return;
  209. + }
  210. +
  211. + if (objPtr->typePtr != &tclHydraType) {
  212. + SetHydraFromAny(NULL, objPtr);
  213. + }
  214. +
  215. + HydraGetIntRep(objPtr, hydraPtr);
  216. +
  217. + if (irPtr) {
  218. + int firstAvailableSlot = -1;
  219. +
  220. + /* If we have an existing client with a matching type, we need to
  221. + * update that intrep even if there is an open slot before it */
  222. + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
  223. + HydraClient *clientPtr = &hydraPtr->client[i];
  224. +
  225. + if (clientPtr->typePtr == typePtr) {
  226. + Tcl_Obj fakeObj;
  227. +
  228. + /* Free the matching client intrep, using a fake obj */
  229. + memset(&fakeObj, 0, sizeof(fakeObj));
  230. + fakeObj.typePtr = typePtr;
  231. + fakeObj.internalRep = clientPtr->internalRep;
  232. + //Tcl_InvalidateStringRep(&fakeObj);
  233. + TclFreeIntRep(&fakeObj);
  234. +
  235. + if (fakeObj.refCount > 0) {
  236. + Tcl_Panic("Invalid reference taken to fakeObj while "
  237. + "freeing hydra client interp for %s",
  238. + typePtr->name);
  239. + }
  240. +
  241. + /* Update the intrep */
  242. + clientPtr->internalRep = *irPtr;
  243. + return;
  244. + } else if (firstAvailableSlot == -1 && clientPtr->typePtr == NULL) {
  245. + /* Record the first available slot in case we need to add this
  246. + * intrep there */
  247. + firstAvailableSlot = i;
  248. + }
  249. + }
  250. +
  251. + if (firstAvailableSlot > -1) {
  252. + HydraClient *clientPtr = &hydraPtr->client[firstAvailableSlot];
  253. +
  254. + if (clientPtr->typePtr == NULL) {
  255. + /* Found available slot, put this intrep there */
  256. + clientPtr->internalRep = *irPtr;
  257. + clientPtr->typePtr = typePtr;
  258. + return;
  259. + }
  260. + }
  261. +
  262. + /* No available client slots. Upconvert to linked list? */
  263. + Tcl_Panic("Unable to add client intrep for %s to hydra: "
  264. + "No slots available", typePtr->name);
  265. + } else {
  266. + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
  267. + HydraClient *clientPtr = &hydraPtr->client[i];
  268. +
  269. + if (clientPtr->typePtr == typePtr) {
  270. + Tcl_Obj fakeObj;
  271. +
  272. + /* Free the matching client intrep, using a fake obj */
  273. + memset(&fakeObj, 0, sizeof(fakeObj));
  274. + fakeObj.typePtr = typePtr;
  275. + fakeObj.internalRep = clientPtr->internalRep;
  276. + //Tcl_InvalidateStringRep(&fakeObj);
  277. + TclFreeIntRep(&fakeObj);
  278. +
  279. + if (fakeObj.refCount > 0) {
  280. + Tcl_Panic("Invalid reference taken to fakeObj while "
  281. + "freeing hydra client interp for %s",
  282. + typePtr->name);
  283. + }
  284. +
  285. + /* Mark the client slot as available */
  286. + clientPtr->typePtr = NULL;
  287. + memset(&clientPtr->internalRep, 0, sizeof(clientPtr->internalRep));
  288. + return;
  289. + }
  290. + }
  291. }
  292. }
  293.  
  294. @@ -1878,8 +2106,7 @@ Tcl_StoreIntRep(
  295. * NULL if no such internal representation exists.
  296. *
  297. * Side effects:
  298. - * Calls the freeIntRepProc of the current Tcl_ObjType, if any.
  299. - * Sets the internalRep and typePtr fields to the submitted values.
  300. + * None.
  301. *
  302. *----------------------------------------------------------------------
  303. */
  304. @@ -1889,13 +2116,27 @@ Tcl_FetchIntRep(
  305. Tcl_Obj *objPtr, /* Object to fetch from. */
  306. const Tcl_ObjType *typePtr) /* Requested type */
  307. {
  308. - /* If objPtr type doesn't match request, nothing can be fetched */
  309. - if (objPtr->typePtr != typePtr) {
  310. - return NULL;
  311. + if (objPtr->typePtr == typePtr) {
  312. + /* Type match! objPtr IntRep is the one sought. */
  313. + return &(objPtr->internalRep);
  314. + }
  315. +
  316. + if (objPtr->typePtr == &tclHydraType) {
  317. + int i;
  318. + Hydra *hydraPtr;
  319. +
  320. + HydraGetIntRep(objPtr, hydraPtr);
  321. +
  322. + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
  323. + HydraClient *clientPtr = &hydraPtr->client[i];
  324. +
  325. + if (clientPtr->typePtr == typePtr) {
  326. + return &(clientPtr->internalRep);
  327. + }
  328. + }
  329. }
  330.  
  331. - /* Type match! objPtr IntRep is the one sought. */
  332. - return &(objPtr->internalRep);
  333. + return NULL;
  334. }
  335.  
  336. /*
  337. @@ -4694,6 +4935,32 @@ Tcl_RepresentationCmd(
  338. Tcl_AppendToObj(descObj, ", no string representation", -1);
  339. }
  340.  
  341. + if (objv[1]->typePtr == &tclHydraType) {
  342. + int i;
  343. + Hydra *hydraPtr;
  344. +
  345. + Tcl_AppendToObj(descObj, ", with client representations:", -1);
  346. + HydraGetIntRep(objv[1], hydraPtr);
  347. + for (i=0; i<MAX_HYDRA_CLIENTS; i++) {
  348. + HydraClient *clientPtr = &hydraPtr->client[i];
  349. +
  350. + if (clientPtr->typePtr == NULL) {
  351. + continue;
  352. + }
  353. +
  354. + Tcl_AppendPrintfToObj(descObj, "\n\t%d: %s", i, clientPtr->typePtr->name);
  355. +
  356. + if (clientPtr->typePtr == &tclDoubleType) {
  357. + Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
  358. + clientPtr->internalRep.doubleValue);
  359. + } else {
  360. + Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
  361. + (void *) clientPtr->internalRep.twoPtrValue.ptr1,
  362. + (void *) clientPtr->internalRep.twoPtrValue.ptr2);
  363. + }
  364. + }
  365. + }
  366. +
  367. Tcl_SetObjResult(interp, descObj);
  368. return TCL_OK;
  369. }