Posted to tcl by apw at Tue Jul 31 19:40:06 GMT 2007view raw

  1. /*
  2. * ----------------------------------------------------------------------
  3. *
  4. * TclOONewProcMethod --
  5. *
  6. * Create a new procedure-like method for an object.
  7. *
  8. * ----------------------------------------------------------------------
  9. */
  10.  
  11. Method *
  12. TclOONewProcMethod(
  13. Tcl_Interp *interp, /* The interpreter containing the object. */
  14. Object *oPtr, /* The object to modify. */
  15. int flags, /* Whether this is a public method. */
  16. Tcl_Obj *nameObj, /* The name of the method, which must not be
  17. * NULL. */
  18. Tcl_Obj *argsObj, /* The formal argument list for the method,
  19. * which must not be NULL. */
  20. Tcl_Obj *bodyObj) /* The body of the method, which must not be
  21. * NULL. */
  22. {
  23. register ProcedureMethod *pmPtr;
  24. Method *mPtr;
  25.  
  26. if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) {
  27. return NULL;
  28. }
  29. pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
  30. pmPtr->procPtr->cmdPtr = NULL;
  31. pmPtr->flags = flags & USE_DECLARER_NS;
  32.  
  33. mPtr = (Method *)Tcl_OONewProcMethod(interp, oPtr, flags,
  34. nameObj, argsObj, bodyObj, &procMethodType, &pmPtr->procPtr, pmPtr);
  35. if (mPtr == NULL) {
  36. ckfree((char *) pmPtr);
  37. }
  38. return mPtr;
  39. }
  40.  
  41. /*
  42. * ----------------------------------------------------------------------
  43. *
  44. * Tcl_OONewProcMethod --
  45. *
  46. * Create a new procedure-like method for an object (public interface).
  47. *
  48. * ----------------------------------------------------------------------
  49. */
  50.  
  51. Tcl_Method *
  52. Tcl_OONewProcMethod(
  53. Tcl_Interp *interp, /* The interpreter containing the object. */
  54. Object *oPtr, /* The object to modify. */
  55. int flags, /* Whether this is a public method. */
  56. Tcl_Obj *nameObj, /* The name of the method, which must not be
  57. * NULL. */
  58. Tcl_Obj *argsObj, /* The formal argument list for the method,
  59. * which must not be NULL. */
  60. Tcl_Obj *bodyObj, /* The body of the method, which must not be
  61. * NULL. */
  62. const Tcl_MethodType *typePtr,
  63. Proc **procPtrPtr, /* pointer to proc data */
  64. ClientData clientData) /* client data for Tcl_NewMethod call */
  65. {
  66. Interp *iPtr = (Interp *) interp;
  67. int argsc;
  68. Tcl_Obj **argsv;
  69. const char *procName;
  70.  
  71. procName = TclGetString(nameObj);
  72. if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
  73. procPtrPtr) != TCL_OK) {
  74. return NULL;
  75. }
  76.  
  77. if (iPtr->cmdFramePtr) {
  78. CmdFrame context = *iPtr->cmdFramePtr;
  79.  
  80. if (context.type == TCL_LOCATION_BC) {
  81. /*
  82. * Retrieve source information from the bytecode, if possible. If
  83. * the information is retrieved successfully, context.type will be
  84. * TCL_LOCATION_SOURCE and the reference held by
  85. * context.data.eval.path will be counted.
  86. */
  87.  
  88. TclGetSrcInfoForPc(&context);
  89. } else if (context.type == TCL_LOCATION_SOURCE) {
  90. /*
  91. * The copy into 'context' up above has created another reference
  92. * to 'context.data.eval.path'; account for it.
  93. */
  94.  
  95. Tcl_IncrRefCount(context.data.eval.path);
  96. }
  97.  
  98. if (context.type == TCL_LOCATION_SOURCE) {
  99. /*
  100. * We can account for source location within a proc only if the
  101. * proc body was not created by substitution.
  102. */
  103.  
  104. if (context.line
  105. && (context.nline >= 4) && (context.line[3] >= 0)) {
  106. int isNew;
  107. CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
  108. Tcl_HashEntry *hPtr;
  109.  
  110. cfPtr->level = -1;
  111. cfPtr->type = context.type;
  112. cfPtr->line = (int *) ckalloc(sizeof(int));
  113. cfPtr->line[0] = context.line[3];
  114. cfPtr->nline = 1;
  115. cfPtr->framePtr = NULL;
  116. cfPtr->nextPtr = NULL;
  117.  
  118. cfPtr->data.eval.path = context.data.eval.path;
  119. Tcl_IncrRefCount(cfPtr->data.eval.path);
  120.  
  121. cfPtr->cmd.str.cmd = NULL;
  122. cfPtr->cmd.str.len = 0;
  123.  
  124. hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
  125. (char *) pmPtr->procPtr, &isNew);
  126. Tcl_SetHashValue(hPtr, cfPtr);
  127. }
  128.  
  129. /*
  130. * 'context' is going out of scope; account for the reference that
  131. * it's holding to the path name.
  132. */
  133.  
  134. Tcl_DecrRefCount(context.data.eval.path);
  135. context.data.eval.path = NULL;
  136. }
  137. }
  138.  
  139. return Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
  140. flags, typePtr, clientData);
  141. }
  142.  
  143. /*
  144. * ----------------------------------------------------------------------
  145. *
  146. * TclOONewProcClassMethod --
  147. *
  148. * Create a new procedure-like method for a class.
  149. *
  150. * ----------------------------------------------------------------------
  151. */
  152.  
  153. Method *
  154. TclOONewProcClassMethod(
  155. Tcl_Interp *interp, /* The interpreter containing the class. */
  156. Class *clsPtr, /* The class to modify. */
  157. int flags, /* Whether this is a public method. */
  158. Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
  159. * if so, up to caller to manage storage
  160. * (e.g., because it is a constructor or
  161. * destructor). */
  162. Tcl_Obj *argsObj, /* The formal argument list for the method,
  163. * which may be NULL; if so, it is equivalent
  164. * to an empty list. */
  165. Tcl_Obj *bodyObj) /* The body of the method, which must not be
  166. * NULL. */
  167. {
  168. register ProcedureMethod *pmPtr;
  169. Method *mPtr;
  170.  
  171. if (argsObj == NULL) {
  172. argsLen = -1;
  173. argsObj = Tcl_NewObj();
  174. Tcl_IncrRefCount(argsObj);
  175. procName = "<destructor>";
  176. } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
  177. return NULL;
  178. } else {
  179. procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
  180. }
  181. pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
  182. pmPtr->procPtr->cmdPtr = NULL;
  183. pmPtr->flags = flags & USE_DECLARER_NS;
  184. mPtr = (Method *)Tcl_OONewProcClassMethod(interp, oPtr, flags,
  185. nameObj, argsObj, bodyObj, &procMethodType, &pmPtr->procPtr, pmPtr);
  186. if (mPtr == NULL) {
  187. ckfree((char *) pmPtr);
  188. }
  189. return mPtr;
  190. }
  191. /*
  192. * ----------------------------------------------------------------------
  193. *
  194. * Tcl_OONewProcClassMethod --
  195. *
  196. * Create a new procedure-like method for a class (public interface).
  197. *
  198. * ----------------------------------------------------------------------
  199. */
  200.  
  201. Tcl_Method *
  202. Tcl_OONewProcClassMethod(
  203. Tcl_Interp *interp, /* The interpreter containing the class. */
  204. Class *clsPtr, /* The class to modify. */
  205. int flags, /* Whether this is a public method. */
  206. Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
  207. * if so, up to caller to manage storage
  208. * (e.g., because it is a constructor or
  209. * destructor). */
  210. Tcl_Obj *argsObj, /* The formal argument list for the method,
  211. * which may be NULL; if so, it is equivalent
  212. * to an empty list. */
  213. Tcl_Obj *bodyObj, /* The body of the method, which must not be
  214. * NULL. */
  215. const Tcl_MethodType *typePtr,
  216. Proc **procPtrPtr, /* pointer to proc data */
  217. ClientData clientData) /* client data for Tcl_NewMethod call */
  218. {
  219. Interp *iPtr = (Interp *) interp;
  220. int argsLen; /* -1 => delete argsObj before exit */
  221. const char *procName;
  222.  
  223. if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
  224. procPtrPtr) != TCL_OK) {
  225. if (argsLen == -1) {
  226. Tcl_DecrRefCount(argsObj);
  227. }
  228. ckfree((char *) pmPtr);
  229. return NULL;
  230. }
  231. if (argsLen == -1) {
  232. Tcl_DecrRefCount(argsObj);
  233. }
  234.  
  235. if (iPtr->cmdFramePtr) {
  236. CmdFrame context = *iPtr->cmdFramePtr;
  237.  
  238. if (context.type == TCL_LOCATION_BC) {
  239. /*
  240. * Retrieve source information from the bytecode, if possible. If
  241. * the information is retrieved successfully, context.type will be
  242. * TCL_LOCATION_SOURCE and the reference held by
  243. * context.data.eval.path will be counted.
  244. */
  245.  
  246. TclGetSrcInfoForPc(&context);
  247. } else if (context.type == TCL_LOCATION_SOURCE) {
  248. /*
  249. * The copy into 'context' up above has created another reference
  250. * to 'context.data.eval.path'; account for it.
  251. */
  252.  
  253. Tcl_IncrRefCount(context.data.eval.path);
  254. }
  255.  
  256. if (context.type == TCL_LOCATION_SOURCE) {
  257. /*
  258. * We can account for source location within a proc only if the
  259. * proc body was not created by substitution.
  260. */
  261.  
  262. if (context.line
  263. && (context.nline >= 4) && (context.line[3] >= 0)) {
  264. int isNew;
  265. CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
  266. Tcl_HashEntry *hPtr;
  267.  
  268. cfPtr->level = -1;
  269. cfPtr->type = context.type;
  270. cfPtr->line = (int *) ckalloc(sizeof(int));
  271. cfPtr->line[0] = context.line[3];
  272. cfPtr->nline = 1;
  273. cfPtr->framePtr = NULL;
  274. cfPtr->nextPtr = NULL;
  275.  
  276. cfPtr->data.eval.path = context.data.eval.path;
  277. Tcl_IncrRefCount(cfPtr->data.eval.path);
  278.  
  279. cfPtr->cmd.str.cmd = NULL;
  280. cfPtr->cmd.str.len = 0;
  281.  
  282. hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
  283. (char *) pmPtr->procPtr, &isNew);
  284. Tcl_SetHashValue(hPtr, cfPtr);
  285. }
  286.  
  287. /*
  288. * 'context' is going out of scope; account for the reference that
  289. * it's holding to the path name.
  290. */
  291.  
  292. Tcl_DecrRefCount(context.data.eval.path);
  293. context.data.eval.path = NULL;
  294. }
  295. }
  296.  
  297. return (Tcl_Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
  298. nameObj, flags, typePtrclientData);
  299. }