itcl_methods.c

这是一个Linux下的集成开发环境

    ItclMember* member;        /* member containing code body */
{
    ItclMemberCode *mcode = member->code;

    int result;

    /*
     *  If the implementation has not yet been defined, try to
     *  autoload it now.
     */
    if ((mcode->flags & ITCL_IMPLEMENT_NONE) != 0) {
        result = Tcl_VarEval(interp, "::auto_load ", member->fullname,
            (char*)NULL);

        if (result != TCL_OK) {
            char msg[256];
            sprintf(msg, "\n    (while autoloading code for \"%.100s\")",
                member->fullname);
            Tcl_AddErrorInfo(interp, msg);
            return result;
        }
        Tcl_ResetResult(interp);  /* get rid of 1/0 status */
    }

    /*
     *  If the implementation is still not available, then
     *  autoloading must have failed.
     *
     *  TRICKY NOTE:  If code has been autoloaded, then the
     *    old mcode pointer is probably invalid.  Go back to
     *    the member and look at the current code pointer again.
     */
    mcode = member->code;

    if ((mcode->flags & ITCL_IMPLEMENT_NONE) != 0) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "member function \"", member->fullname,
            "\" is not defined and cannot be autoloaded",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  If the member is a constructor and the class has an
     *  initialization command, compile it here.
     */
    if ((member->flags & ITCL_CONSTRUCTOR) != 0 &&
        (member->classDefn->initCode != NULL)) {

        result = TclProcCompileProc(interp, mcode->procPtr,
            member->classDefn->initCode, (Namespace*)member->classDefn->namesp,
            "initialization code for", member->fullname);

        if (result != TCL_OK) {
            return result;
        }
    }

    /*
     *  If the code body has a Tcl implementation, then compile it here.
     */
    if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {

        result = TclProcCompileProc(interp, mcode->procPtr,
            mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp,
            "body for", member->fullname);

        if (result != TCL_OK) {
            return result;
        }
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_EvalMemberCode()
 *
 *  Used to execute an ItclMemberCode representation of a code
 *  fragment.  This code may be a body of Tcl commands, or a C handler
 *  procedure.
 *
 *  Executes the command with the given arguments (objc,objv) and
 *  returns an integer status code (TCL_OK/TCL_ERROR).  Returns the
 *  result string or an error message in the interpreter.
 * ------------------------------------------------------------------------
 */
int
Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv)
    Tcl_Interp *interp;       /* current interpreter */
    ItclMemberFunc *mfunc;    /* member func, or NULL (for error messages) */
    ItclMember *member;       /* command member containing code */
    ItclObject *contextObj;   /* object context, or NULL */
    int objc;                 /* number of arguments */
    Tcl_Obj *CONST objv[];    /* argument objects */
{
    int result = TCL_OK;
    Tcl_CallFrame *oldFramePtr = NULL;

    int i, transparent, newEntry;
    ItclObjectInfo *info;
    ItclMemberCode *mcode;
    ItclContext context;
    Tcl_CallFrame *framePtr, *transFramePtr;

    /*
     *  If this code does not have an implementation yet, then
     *  try to autoload one.  Also, if this is Tcl code, make sure
     *  that it's compiled and ready to use.
     */
    if (Itcl_GetMemberCode(interp, member) != TCL_OK) {
        return TCL_ERROR;
    }
    mcode = member->code;

    /*
     *  Bump the reference count on this code, in case it is
     *  redefined or deleted during execution.
     */
    Itcl_PreserveData((ClientData)mcode);

    /*
     *  Install a new call frame context for the current code.
     *  If the current call frame is marked as "transparent", then
     *  do an "uplevel" operation to move past it.  Transparent
     *  call frames are installed by Itcl_HandleInstance.  They
     *  provide a way of entering an object context without
     *  interfering with the normal call stack.
     */
    transparent = 0;

    info = member->classDefn->info;
    framePtr = _Tcl_GetCallFrame(interp, 0);
    for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) {
        transFramePtr = (Tcl_CallFrame*)
            Itcl_GetStackValue(&info->transparentFrames, i);

        if (framePtr == transFramePtr) {
            transparent = 1;
            break;
        }
    }

    if (transparent) {
        framePtr = _Tcl_GetCallFrame(interp, 1);
        oldFramePtr = _Tcl_ActivateCallFrame(interp, framePtr);
    }

    if (Itcl_PushContext(interp, member, member->classDefn, contextObj,
        &context) != TCL_OK) {

        return TCL_ERROR;
    }

    /*
     *  If this is a method with a Tcl implementation, or a
     *  constructor with initCode, then parse its arguments now.
     */
    if (mfunc && objc > 0) {
        if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0 ||
            ( (member->flags & ITCL_CONSTRUCTOR) != 0 &&
              (member->classDefn->initCode != NULL) ) ) {

            if (Itcl_AssignArgs(interp, objc, objv, mfunc) != TCL_OK) {
                result = TCL_ERROR;
                goto evalMemberCodeDone;
            }
        }
    }

    /*
     *  If this code is a constructor, and if it is being invoked
     *  when an object is first constructed (i.e., the "constructed"
     *  table is still active within the object), then handle the
     *  "initCode" associated with the constructor and make sure that
     *  all base classes are properly constructed.
     *
     *  TRICKY NOTE:
     *    The "initCode" must be executed here.  This is the only
     *    opportunity where the arguments of the constructor are
     *    available in a call frame.
     */
    if ((member->flags & ITCL_CONSTRUCTOR) && contextObj &&
        contextObj->constructed) {

        result = Itcl_ConstructBase(interp, contextObj, member->classDefn);

        if (result != TCL_OK) {
            goto evalMemberCodeDone;
        }
    }

    /*
     *  Execute the code body...
     */
    if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) {
        result = (*mcode->cfunc.objCmd)(mcode->clientData,
            interp, objc, objv);
    }
    else if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) {
        char **argv;
        argv = (char**)ckalloc( (unsigned)(objc*sizeof(char*)) );
        for (i=0; i < objc; i++) {
            argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL);
        }

        result = (*mcode->cfunc.argCmd)(mcode->clientData,
            interp, objc, argv);

        ckfree((char*)argv);
    }
    else if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) {
      /* CYGNUS LOCAL - Fix for Tcl8.1 */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1
      result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr, 0);
#else
      result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr);
#endif
      /* END CYGNUS LOCAL */
    }
    else {
        panic("itcl: bad implementation flag for %s", member->fullname);
    }

    /*
     *  If this is a constructor or destructor, and if it is being
     *  invoked at the appropriate time, keep track of which methods
     *  have been called.  This information is used to implicitly
     *  invoke constructors/destructors as needed.
     */
    if ((member->flags & ITCL_DESTRUCTOR) && contextObj &&
         contextObj->destructed) {

        Tcl_CreateHashEntry(contextObj->destructed,
            member->classDefn->name, &newEntry);
    }
    if ((member->flags & ITCL_CONSTRUCTOR) && contextObj &&
         contextObj->constructed) {

        Tcl_CreateHashEntry(contextObj->constructed,
            member->classDefn->name, &newEntry);
    }

evalMemberCodeDone:
    Itcl_PopContext(interp, &context);

    if (transparent) {
        (void) _Tcl_ActivateCallFrame(interp, oldFramePtr);
    }
    Itcl_ReleaseData((ClientData)mcode);

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateArgList()
 *
 *  Parses a Tcl list representing an argument declaration and returns
 *  a linked list of CompiledLocal values.  Usually invoked as part
 *  of Itcl_CreateMemberFunc() when a new method or procedure is being
 *  defined.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateArgList(interp, decl, argcPtr, argPtr)
    Tcl_Interp* interp;       /* interpreter managing this function */
    char* decl;               /* string representing argument list */
    int* argcPtr;             /* returns number of args in argument list */
    CompiledLocal** argPtr;   /* returns pointer to parsed argument list */
{
    int status = TCL_OK;  /* assume that this will succeed */

    int i, argc, fargc;
    char **argv, **fargv;
    CompiledLocal *localPtr, *last;

    *argPtr = last = NULL;
    *argcPtr = 0;

    if (decl) {
        if (Tcl_SplitList(interp, decl, &argc, &argv) != TCL_OK) {
            return TCL_ERROR;
        }

        for (i=0; i < argc && status == TCL_OK; i++) {
            if (Tcl_SplitList(interp, argv[i], &fargc, &fargv) != TCL_OK) {
                status = TCL_ERROR;
            }
            else {
                localPtr = NULL;

                if (fargc == 0 || *fargv[0] == '\0') {
                    char mesg[100];
                    sprintf(mesg, "argument #%d has no name", i);
                    Tcl_SetResult(interp, mesg, TCL_VOLATILE);
                    status = TCL_ERROR;
                }
                else if (fargc > 2) {
                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "too many fields in argument specifier \"",
                        argv[i], "\"",
                        (char*)NULL);
                    status = TCL_ERROR;
                }
                else if (strstr(fargv[0],"::")) {
                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "bad argument name \"", fargv[0], "\"",
                        (char*)NULL);
                    status = TCL_ERROR;
                }
                else if (fargc == 1) {
                    localPtr = Itcl_CreateArg(fargv[0], (char*)NULL);
                }
                else {
                    localPtr = Itcl_CreateArg(fargv[0], fargv[1]);
                }

                if (localPtr) {
                    localPtr->frameIndex = i;

                    if (*argPtr == NULL) {
                        *argPtr = last = localPtr;
                    }
                    else {
                        last->nextPtr = localPtr;
                        last = localPtr;
                    }
                }
            }
            ckfree((char*)fargv);
        }
        ckfree((char*)argv);
    }

    /*
     *  If anything went wrong, destroy whatever arguments were
     *  created and return an error.
     */
    if (status == TCL_OK) {
        *argcPtr = argc;
    } else {
        Itcl_DeleteArgList(*argPtr);
        *argPtr = NULL;
    }
    return status;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateArg()
 *
 *  Creates a new Tcl Arg structure and fills it with the given
 *  information.  Returns a pointer to the new Arg structure.
 * ------------------------------------------------------------------------
 */
CompiledLocal*
Itcl_CreateArg(name, init)
    char* name;     /* name of new argument */
    char* init;     /* initial value */
{
    CompiledLocal *localPtr = NULL;
    int nameLen;

    if (name == NULL) {
        name = "";
    }
    nameLen = strlen(name);

    localPtr = (CompiledLocal*)ckalloc(
        (unsigned)(sizeof(CompiledLocal)-sizeof(localPtr->name) + nameLen+1)
    );

    localPtr->nextPtr = NULL;
    localPtr->nameLength = nameLen;
    localPtr->frameIndex = 0;  /* set this later */
    localPtr->flags  = VAR_SCALAR | VAR_ARGUMENT;
    localPtr->resolveInfo = NULL;

    if (init != NULL) {
        localPtr->defValuePtr = Tcl_NewStringObj(init, -1);
        Tcl_IncrRefCount(localPtr->defValuePtr);
    } else {
        localPtr->defValuePtr = NULL;
    }

    strcpy(localPtr->name, name);

    return localPtr;
}

/*