Posted to tcl by apw at Tue Jul 31 19:40:06 GMT 2007view raw
- /*
- * ----------------------------------------------------------------------
- *
- * TclOONewProcMethod --
- *
- * Create a new procedure-like method for an object.
- *
- * ----------------------------------------------------------------------
- */
- Method *
- TclOONewProcMethod(
- Tcl_Interp *interp, /* The interpreter containing the object. */
- Object *oPtr, /* The object to modify. */
- int flags, /* Whether this is a public method. */
- Tcl_Obj *nameObj, /* The name of the method, which must not be
- * NULL. */
- Tcl_Obj *argsObj, /* The formal argument list for the method,
- * which must not be NULL. */
- Tcl_Obj *bodyObj) /* The body of the method, which must not be
- * NULL. */
- {
- register ProcedureMethod *pmPtr;
- Method *mPtr;
- if (Tcl_ListObjGetElements(interp, argsObj, &argsc, &argsv) != TCL_OK) {
- return NULL;
- }
- pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
- pmPtr->procPtr->cmdPtr = NULL;
- pmPtr->flags = flags & USE_DECLARER_NS;
- mPtr = (Method *)Tcl_OONewProcMethod(interp, oPtr, flags,
- nameObj, argsObj, bodyObj, &procMethodType, &pmPtr->procPtr, pmPtr);
- if (mPtr == NULL) {
- ckfree((char *) pmPtr);
- }
- return mPtr;
- }
- /*
- * ----------------------------------------------------------------------
- *
- * Tcl_OONewProcMethod --
- *
- * Create a new procedure-like method for an object (public interface).
- *
- * ----------------------------------------------------------------------
- */
- Tcl_Method *
- Tcl_OONewProcMethod(
- Tcl_Interp *interp, /* The interpreter containing the object. */
- Object *oPtr, /* The object to modify. */
- int flags, /* Whether this is a public method. */
- Tcl_Obj *nameObj, /* The name of the method, which must not be
- * NULL. */
- Tcl_Obj *argsObj, /* The formal argument list for the method,
- * which must not be NULL. */
- Tcl_Obj *bodyObj, /* The body of the method, which must not be
- * NULL. */
- const Tcl_MethodType *typePtr,
- Proc **procPtrPtr, /* pointer to proc data */
- ClientData clientData) /* client data for Tcl_NewMethod call */
- {
- Interp *iPtr = (Interp *) interp;
- int argsc;
- Tcl_Obj **argsv;
- const char *procName;
- procName = TclGetString(nameObj);
- if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
- procPtrPtr) != TCL_OK) {
- return NULL;
- }
- if (iPtr->cmdFramePtr) {
- CmdFrame context = *iPtr->cmdFramePtr;
- if (context.type == TCL_LOCATION_BC) {
- /*
- * Retrieve source information from the bytecode, if possible. If
- * the information is retrieved successfully, context.type will be
- * TCL_LOCATION_SOURCE and the reference held by
- * context.data.eval.path will be counted.
- */
- TclGetSrcInfoForPc(&context);
- } else if (context.type == TCL_LOCATION_SOURCE) {
- /*
- * The copy into 'context' up above has created another reference
- * to 'context.data.eval.path'; account for it.
- */
- Tcl_IncrRefCount(context.data.eval.path);
- }
- if (context.type == TCL_LOCATION_SOURCE) {
- /*
- * We can account for source location within a proc only if the
- * proc body was not created by substitution.
- */
- if (context.line
- && (context.nline >= 4) && (context.line[3] >= 0)) {
- int isNew;
- CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
- Tcl_HashEntry *hPtr;
- cfPtr->level = -1;
- cfPtr->type = context.type;
- cfPtr->line = (int *) ckalloc(sizeof(int));
- cfPtr->line[0] = context.line[3];
- cfPtr->nline = 1;
- cfPtr->framePtr = NULL;
- cfPtr->nextPtr = NULL;
- cfPtr->data.eval.path = context.data.eval.path;
- Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
- hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- (char *) pmPtr->procPtr, &isNew);
- Tcl_SetHashValue(hPtr, cfPtr);
- }
- /*
- * 'context' is going out of scope; account for the reference that
- * it's holding to the path name.
- */
- Tcl_DecrRefCount(context.data.eval.path);
- context.data.eval.path = NULL;
- }
- }
- return Tcl_NewMethod(interp, (Tcl_Object) oPtr, nameObj,
- flags, typePtr, clientData);
- }
- /*
- * ----------------------------------------------------------------------
- *
- * TclOONewProcClassMethod --
- *
- * Create a new procedure-like method for a class.
- *
- * ----------------------------------------------------------------------
- */
- Method *
- TclOONewProcClassMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
- Class *clsPtr, /* The class to modify. */
- int flags, /* Whether this is a public method. */
- Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
- * if so, up to caller to manage storage
- * (e.g., because it is a constructor or
- * destructor). */
- Tcl_Obj *argsObj, /* The formal argument list for the method,
- * which may be NULL; if so, it is equivalent
- * to an empty list. */
- Tcl_Obj *bodyObj) /* The body of the method, which must not be
- * NULL. */
- {
- register ProcedureMethod *pmPtr;
- Method *mPtr;
- if (argsObj == NULL) {
- argsLen = -1;
- argsObj = Tcl_NewObj();
- Tcl_IncrRefCount(argsObj);
- procName = "<destructor>";
- } else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
- return NULL;
- } else {
- procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
- }
- pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
- pmPtr->procPtr->cmdPtr = NULL;
- pmPtr->flags = flags & USE_DECLARER_NS;
- mPtr = (Method *)Tcl_OONewProcClassMethod(interp, oPtr, flags,
- nameObj, argsObj, bodyObj, &procMethodType, &pmPtr->procPtr, pmPtr);
- if (mPtr == NULL) {
- ckfree((char *) pmPtr);
- }
- return mPtr;
- }
- /*
- * ----------------------------------------------------------------------
- *
- * Tcl_OONewProcClassMethod --
- *
- * Create a new procedure-like method for a class (public interface).
- *
- * ----------------------------------------------------------------------
- */
- Tcl_Method *
- Tcl_OONewProcClassMethod(
- Tcl_Interp *interp, /* The interpreter containing the class. */
- Class *clsPtr, /* The class to modify. */
- int flags, /* Whether this is a public method. */
- Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
- * if so, up to caller to manage storage
- * (e.g., because it is a constructor or
- * destructor). */
- Tcl_Obj *argsObj, /* The formal argument list for the method,
- * which may be NULL; if so, it is equivalent
- * to an empty list. */
- Tcl_Obj *bodyObj, /* The body of the method, which must not be
- * NULL. */
- const Tcl_MethodType *typePtr,
- Proc **procPtrPtr, /* pointer to proc data */
- ClientData clientData) /* client data for Tcl_NewMethod call */
- {
- Interp *iPtr = (Interp *) interp;
- int argsLen; /* -1 => delete argsObj before exit */
- const char *procName;
- if (TclCreateProc(interp, NULL, procName, argsObj, bodyObj,
- procPtrPtr) != TCL_OK) {
- if (argsLen == -1) {
- Tcl_DecrRefCount(argsObj);
- }
- ckfree((char *) pmPtr);
- return NULL;
- }
- if (argsLen == -1) {
- Tcl_DecrRefCount(argsObj);
- }
- if (iPtr->cmdFramePtr) {
- CmdFrame context = *iPtr->cmdFramePtr;
- if (context.type == TCL_LOCATION_BC) {
- /*
- * Retrieve source information from the bytecode, if possible. If
- * the information is retrieved successfully, context.type will be
- * TCL_LOCATION_SOURCE and the reference held by
- * context.data.eval.path will be counted.
- */
- TclGetSrcInfoForPc(&context);
- } else if (context.type == TCL_LOCATION_SOURCE) {
- /*
- * The copy into 'context' up above has created another reference
- * to 'context.data.eval.path'; account for it.
- */
- Tcl_IncrRefCount(context.data.eval.path);
- }
- if (context.type == TCL_LOCATION_SOURCE) {
- /*
- * We can account for source location within a proc only if the
- * proc body was not created by substitution.
- */
- if (context.line
- && (context.nline >= 4) && (context.line[3] >= 0)) {
- int isNew;
- CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
- Tcl_HashEntry *hPtr;
- cfPtr->level = -1;
- cfPtr->type = context.type;
- cfPtr->line = (int *) ckalloc(sizeof(int));
- cfPtr->line[0] = context.line[3];
- cfPtr->nline = 1;
- cfPtr->framePtr = NULL;
- cfPtr->nextPtr = NULL;
- cfPtr->data.eval.path = context.data.eval.path;
- Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
- hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- (char *) pmPtr->procPtr, &isNew);
- Tcl_SetHashValue(hPtr, cfPtr);
- }
- /*
- * 'context' is going out of scope; account for the reference that
- * it's holding to the path name.
- */
- Tcl_DecrRefCount(context.data.eval.path);
- context.data.eval.path = NULL;
- }
- }
- return (Tcl_Method *) Tcl_NewClassMethod(interp, (Tcl_Class) clsPtr,
- nameObj, flags, typePtrclientData);
- }