Posted to tcl by apw at Sun Aug 19 11:11:49 GMT 2007view raw

  1. /* missing functions for Itcl to avoid including of tclInt.h */
  2.  
  3. /* these functions exist but are NOT PUBLISHED */
  4. EXTERN int Tcl_PushCallFrame (Tcl_Interp * interp,
  5. Tcl_CallFrame * framePtr,
  6. Tcl_Namespace * nsPtr, int isProcCallFrame);
  7. EXTERN void Tcl_PopCallFrame (Tcl_Interp * interp);
  8. EXTERN void Tcl_GetVariableFullName (Tcl_Interp * interp,
  9. Tcl_Var variable, Tcl_Obj * objPtr);
  10. EXTERN Tcl_Var Tcl_FindNamespaceVar (Tcl_Interp * interp,
  11. CONST char * name, Tcl_Namespace * contextNsPtr, int flags);
  12. /* end of functions that exist but are NOT PUBLISHED */
  13.  
  14.  
  15. This is the include file for interfaces I would like to have in Tcl core
  16. The defines with _XXX are just there, if the interfaces do not go into the core
  17.  
  18. /*---------------------------------------------------
  19. * itclMigrate2TclCore.h
  20. *---------------------------------------------------
  21. */
  22.  
  23. /* here come the definitions for code which should be migrated to Tcl core */
  24. /* these functions DO NOT exist and are not published */
  25. typedef struct Tcl_Proc_ *Tcl_Proc;
  26.  
  27. typedef struct Tcl_CallFrameInfo {
  28. Tcl_Namespace *nsPtr;
  29. int flags;
  30. int objc;
  31. Tcl_Obj *CONST *objv;
  32. Tcl_CallFrame CONST *callerPtr;
  33. Tcl_CallFrame CONST *callerVarPtr;
  34. int level;
  35. Tcl_Proc procPtr;
  36. ClientData clientData;
  37. #ifdef ARNULF_FOR_ITCL_CODE
  38. Tcl_Resolve *resolvePtr;
  39. #endif
  40. } Tcl_CallFrameInfo;
  41.  
  42. typedef void (*Tcl_ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
  43.  
  44. #define Tcl_GetOriginalCommand _Tcl_GetOriginalCommand
  45. #define Tcl_SetCallFrameResolver _Tcl_SetCallFrameResolver
  46. #define Tcl_GetNamespaceCommandTable _Tcl_GetNamespaceCommandTable
  47. #define Tcl_GetNamespaceChildTable _Tcl_GetNamespaceChildTable
  48. #define Tcl_GetCallFrameInfo _Tcl_GetCallFrameInfo
  49. #define Tcl_SetCallFrameInfo _Tcl_SetCallFrameInfo
  50. #define Tcl_InitRewriteEnsemble _Tcl_InitRewriteEnsemble
  51. #define Tcl_ResetRewriteEnsemble _Tcl_ResetRewriteEnsemble
  52. #define Tcl_CreateProc _Tcl_CreateProc
  53. #define Tcl_ProcDeleteProc _Tcl_ProcDeleteProc
  54. #define Tcl_GetObjInterpProc _Tcl_GetObjInterpProc
  55. #define Tcl_SetProcCmd _Tcl_SetProcCmd
  56. #define Tcl_SetNamespaceResolver _Tcl_SetNamespaceResolver
  57. #define Tcl_InvokeNamespaceProc _Tcl_InvokeNamespaceProc
  58.  
  59. EXTERN Tcl_Command _Tcl_GetOriginalCommand(Tcl_Command command);
  60. EXTERN Tcl_HashTable *_Tcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr);
  61.  
  62. EXTERN int _Tcl_SetCallFrameResolver(Tcl_Interp *interp,
  63. Tcl_Resolve *resolvePtr);
  64. EXTERN Tcl_HashTable *_Tcl_GetNamespaceCommandTable(Tcl_Namespace *nsPtr);
  65. EXTERN int _Tcl_GetCallFrameInfo(Tcl_Interp *interp,
  66. const Tcl_CallFrame *framePtr, Tcl_CallFrameInfo *infoPtr);
  67. EXTERN int _Tcl_SetCallFrameInfo(Tcl_Interp *interp,
  68. Tcl_CallFrame *framePtr, CONST Tcl_CallFrameInfo *infoPtr);
  69. EXTERN int _Tcl_InitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
  70. int numInserted, int objc, Tcl_Obj *const *objv);
  71. EXTERN void _Tcl_ResetRewriteEnsemble(Tcl_Interp *interp,
  72. int isRootEnsemble);
  73. EXTERN int _Tcl_CreateProc(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
  74. CONST char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr,
  75. Tcl_Proc *procPtrPtr);
  76. EXTERN void _Tcl_ProcDeleteProc(ClientData clientData);
  77. EXTERN void *_Tcl_GetObjInterpProc(void);
  78. EXTERN int _Tcl_SetNamespaceResolver(Tcl_Namespace *nsPtr,
  79. Tcl_Resolve *resolvePtr);
  80. EXTERN int _Tcl_InvokeNamespaceProc(Tcl_Interp *interp, Tcl_Proc proc,
  81. Tcl_Namespace *nsPtr, Tcl_Obj *namePtr, Tcl_ProcErrorProc errorProc,
  82. int objc, Tcl_Obj *const *objv);
  83.  
  84. /* end migration code */
  85.  
  86. That is the Implementation I have done for providing the interfaces above
  87.  
  88. /*
  89. * ------------------------------------------------------------------------
  90. * PACKAGE: [incr Tcl]
  91. * DESCRIPTION: Object-Oriented Extensions to Tcl
  92. *
  93. * This file contains procedures that belong in the Tcl/Tk core.
  94. * Hopefully, they'll migrate there soon.
  95. *
  96. * ========================================================================
  97. * AUTHOR: Arnulf Wiedemann
  98. *
  99. * RCS: $Id: itclMigrate2Core.c,v 1.0 2007/07/20 12:09:56 wiede Exp $
  100. * ========================================================================
  101. * Copyright (c) 1993-1998 Lucent Technologies, Inc.
  102. * ------------------------------------------------------------------------
  103. * See the file "license.terms" for information on usage and redistribution
  104. * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  105. */
  106. #include <tcl.h>
  107. #include <tclInt.h>
  108. #include "itclMigrate2TclCore.h"
  109.  
  110. int
  111. _Tcl_GetCallFrameInfo(
  112. Tcl_Interp *interp, /* Interpreter in which to look for */
  113. const Tcl_CallFrame *framePtr, /* if NULL use framePtr from interp */
  114. Tcl_CallFrameInfo *infoPtr) /* Where to store information */
  115. {
  116. CallFrame *myFramePtr = (CallFrame *)framePtr;
  117.  
  118. if (infoPtr == NULL) {
  119. return TCL_ERROR;
  120. }
  121. if (myFramePtr == NULL) {
  122. if (interp == NULL) {
  123. return TCL_ERROR;
  124. }
  125. myFramePtr = ((Interp *)interp)->varFramePtr;
  126. }
  127. infoPtr->nsPtr = (Tcl_Namespace *)myFramePtr->nsPtr;
  128. infoPtr->flags = myFramePtr->isProcCallFrame;
  129. infoPtr->objc = myFramePtr->objc;
  130. infoPtr->objv = myFramePtr->objv;
  131. infoPtr->callerPtr = (Tcl_CallFrame *)myFramePtr->callerPtr;
  132. infoPtr->callerVarPtr = (Tcl_CallFrame *)myFramePtr->callerVarPtr;
  133. infoPtr->level = myFramePtr->level;
  134. infoPtr->procPtr = (Tcl_Proc)myFramePtr->procPtr;
  135. infoPtr->clientData = myFramePtr->clientData;
  136. #ifdef ARNULF_FOR_ITCL_CODE
  137. infoPtr->resolvePtr = myFramePtr->resolvePtr;
  138. #endif
  139. return TCL_OK;
  140. }
  141.  
  142. int
  143. _Tcl_SetCallFrameInfo(
  144. Tcl_Interp *interp, /* Interpreter in which to look for */
  145. Tcl_CallFrame *framePtr, /* if NULL use framePtr from interp */
  146. CONST Tcl_CallFrameInfo *infoPtr) /* Where to find information */
  147. {
  148. CallFrame *myFramePtr = (CallFrame *)framePtr;
  149.  
  150. if (infoPtr == NULL) {
  151. return TCL_ERROR;
  152. }
  153. if (myFramePtr == NULL) {
  154. if (interp == NULL) {
  155. return TCL_ERROR;
  156. }
  157. myFramePtr = ((Interp *)interp)->varFramePtr;
  158. }
  159. myFramePtr->nsPtr = (Namespace *)infoPtr->nsPtr;
  160. myFramePtr->isProcCallFrame = infoPtr->flags;
  161. myFramePtr->objc = infoPtr->objc;
  162. myFramePtr->objv = infoPtr->objv ;
  163. myFramePtr->procPtr = (Proc *)infoPtr->procPtr;
  164. myFramePtr->clientData = infoPtr->clientData;
  165. #ifdef ARNULF_FOR_ITCL_CODE
  166. myFramePtr->resolvePtr = infoPtr->resolvePtr;
  167. #endif
  168. return TCL_OK;
  169. }
  170.  
  171. Tcl_Command
  172. _Tcl_GetOriginalCommand(
  173. Tcl_Command command)
  174. {
  175. return TclGetOriginalCommand(command);
  176. }
  177.  
  178. int
  179. _Tcl_SetCallFrameResolver(
  180. Tcl_Interp *interp,
  181. Tcl_Resolve *resolvePtr)
  182. {
  183. Tcl_CallFrameInfo cfInfo;
  184.  
  185. Tcl_GetCallFrameInfo(interp, NULL, &cfInfo);
  186. cfInfo.resolvePtr = resolvePtr;
  187. cfInfo.flags |= FRAME_HAS_RESOLVER;
  188. Tcl_SetCallFrameInfo(interp, NULL, &cfInfo);
  189. return TCL_OK;
  190. }
  191.  
  192. Tcl_HashTable *
  193. _Tcl_GetNamespaceCommandTable(
  194. Tcl_Namespace *nsPtr)
  195. {
  196. return &((Namespace *)nsPtr)->cmdTable;
  197. }
  198.  
  199. Tcl_HashTable *
  200. _Tcl_GetNamespaceChildTable(
  201. Tcl_Namespace *nsPtr)
  202. {
  203. return &((Namespace *)nsPtr)->childTable;
  204. }
  205.  
  206. int
  207. _Tcl_InitRewriteEnsemble(
  208. Tcl_Interp *interp,
  209. int numRemoved,
  210. int numInserted,
  211. int objc,
  212. Tcl_Obj *const *objv)
  213. {
  214. Interp *iPtr = (Interp *) interp;
  215.  
  216. int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
  217.  
  218. if (isRootEnsemble) {
  219. iPtr->ensembleRewrite.sourceObjs = objv;
  220. iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
  221. iPtr->ensembleRewrite.numInsertedObjs = numInserted;
  222. } else {
  223. int numIns = iPtr->ensembleRewrite.numInsertedObjs;
  224. if (numIns < numRemoved) {
  225. iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
  226. iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1;
  227. } else {
  228. iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
  229. }
  230. }
  231. return isRootEnsemble;
  232. }
  233.  
  234. void
  235. _Tcl_ResetRewriteEnsemble(
  236. Tcl_Interp *interp,
  237. int isRootEnsemble)
  238. {
  239. Interp *iPtr = (Interp *) interp;
  240.  
  241. if (isRootEnsemble) {
  242. iPtr->ensembleRewrite.sourceObjs = NULL;
  243. iPtr->ensembleRewrite.numRemovedObjs = 0;
  244. iPtr->ensembleRewrite.numInsertedObjs = 0;
  245. }
  246. }
  247.  
  248. int
  249. _Tcl_CreateProc(
  250. Tcl_Interp *interp, /* Interpreter containing proc. */
  251. Tcl_Namespace *nsPtr, /* Namespace containing this proc. */
  252. CONST char *procName, /* Unqualified name of this proc. */
  253. Tcl_Obj *argsPtr, /* Description of arguments. */
  254. Tcl_Obj *bodyPtr, /* Command body. */
  255. Tcl_Proc *procPtrPtr) /* Returns: pointer to proc data. */
  256. {
  257. return TclCreateProc(interp, (Namespace *)nsPtr, procName, argsPtr,
  258. bodyPtr, (Proc **)procPtrPtr);
  259. }
  260.  
  261. void *
  262. _Tcl_GetObjInterpProc(
  263. void)
  264. {
  265. return (void *)TclGetObjInterpProc();
  266. }
  267.  
  268. int
  269. _Tcl_SetNamespaceResolver(
  270. Tcl_Namespace *nsPtr,
  271. Tcl_Resolve *resolvePtr)
  272. {
  273. if (nsPtr == NULL) {
  274. return TCL_ERROR;
  275. }
  276. ((Namespace *)nsPtr)->resolvePtr = resolvePtr;
  277. return TCL_OK;
  278. }
  279.  
  280. void
  281. _Tcl_ProcDeleteProc(
  282. ClientData clientData)
  283. {
  284. TclProcDeleteProc(clientData);
  285. }
  286.  
  287. int
  288. _Tcl_InvokeNamespaceProc(
  289. Tcl_Interp *interp,
  290. Tcl_Proc proc,
  291. Tcl_Namespace *nsPtr,
  292. Tcl_Obj *namePtr,
  293. Tcl_ProcErrorProc errorProc,
  294. int objc,
  295. Tcl_Obj *const *objv)
  296. {
  297. CallFrame frame;
  298. CallFrame *framePtr = &frame;
  299. Command cmd;
  300. Proc *procPtr = (Proc *)proc;
  301. int flags = 0;;
  302. int result;
  303.  
  304. memset(&cmd, 0, sizeof(Command));
  305. cmd.nsPtr = (Namespace *) nsPtr;
  306. cmd.clientData = NULL;
  307. procPtr->cmdPtr = &cmd;
  308.  
  309. result = TclProcCompileProc(interp, procPtr,
  310. procPtr->bodyPtr, (Namespace *) nsPtr, "body of method",
  311. Tcl_GetString(namePtr));
  312. if (result != TCL_OK) {
  313. return result;
  314. }
  315.  
  316. /*
  317. * Make the stack frame and fill it out with information about this call.
  318. * This operation may fail.
  319. */
  320.  
  321.  
  322. flags |= FRAME_IS_PROC;
  323. result = TclPushStackFrame(interp, &framePtr, nsPtr, flags);
  324. if (result != TCL_OK) {
  325. return result;
  326. }
  327.  
  328. framePtr->clientData = NULL;
  329. framePtr->objc = objc;
  330. framePtr->objv = objv;
  331. framePtr->procPtr = procPtr;
  332.  
  333. /*
  334. * Now invoke the body of the method. Note that we need to take special
  335. * action when doing unknown processing to ensure that the missing method
  336. * name is passed as an argument.
  337. */
  338.  
  339. result = TclObjInterpProcCore(interp, namePtr, 1, errorProc);
  340.  
  341. return result;
  342.  
  343. }
  344.