Posted to tcl by apw at Tue Jul 31 19:40:06 GMT 2007view pretty
/*
* ----------------------------------------------------------------------
*
* 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);
}