itcl_parse.c

linux 下的源代码分析阅读器 red hat公司新版

    }

    for (objc--,objv++; objc > 0; objc--,objv++) {

        /*
         *  Make sure that the base class name is known in the
         *  parent namespace (currently active).  If not, try
         *  to autoload its definition.
         */
        token = Tcl_GetStringFromObj(*objv, (int*)NULL);
        baseCdefnPtr = Itcl_FindClass(interp, token, /* autoload */ 1);
        if (!baseCdefnPtr) {
            Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
            int errlen;
            char *errmsg;

            Tcl_IncrRefCount(resultPtr);
            errmsg = Tcl_GetStringFromObj(resultPtr, &errlen);

            Tcl_ResetResult(interp);
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "cannot inherit from \"", token, "\"",
                (char*)NULL);

            if (errlen > 0) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    " (", errmsg, ")", (char*)NULL);
            }
            Tcl_DecrRefCount(resultPtr);
            goto inheritError;
        }

        /*
         *  Make sure that the base class is not the same as the
         *  class that is being built.
         */
        if (baseCdefnPtr == cdefnPtr) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "class \"", cdefnPtr->name, "\" cannot inherit from itself",
                (char*)NULL);
            goto inheritError;
        }

        Itcl_AppendList(&cdefnPtr->bases, (ClientData)baseCdefnPtr);
        Itcl_PreserveData((ClientData)baseCdefnPtr);
    }

    /*
     *  Scan through the inheritance list to make sure that no
     *  class appears twice.
     */
    elem = Itcl_FirstListElem(&cdefnPtr->bases);
    while (elem) {
        elem2 = Itcl_NextListElem(elem);
        while (elem2) {
            if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) {
                cdPtr = (ItclClass*)Itcl_GetListValue(elem);
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "class \"", cdefnPtr->fullname,
                    "\" cannot inherit base class \"",
                    cdPtr->fullname, "\" more than once",
                    (char*)NULL);
                goto inheritError;
            }
            elem2 = Itcl_NextListElem(elem2);
        }
        elem = Itcl_NextListElem(elem);
    }

    /*
     *  Add each base class and all of its base classes into
     *  the heritage for the current class.  Along the way, make
     *  sure that no class appears twice in the heritage.
     */
    Itcl_InitHierIter(&hier, cdefnPtr);
    cdPtr = Itcl_AdvanceHierIter(&hier);  /* skip the class itself */
    cdPtr = Itcl_AdvanceHierIter(&hier);
    while (cdPtr != NULL) {
        (void) Tcl_CreateHashEntry(&cdefnPtr->heritage,
            (char*)cdPtr, &newEntry);

        if (!newEntry) {
            break;
        }
        cdPtr = Itcl_AdvanceHierIter(&hier);
    }
    Itcl_DeleteHierIter(&hier);

    /*
     *  Same base class found twice in the hierarchy?
     *  Then flag error.  Show the list of multiple paths
     *  leading to the same base class.
     */
    if (!newEntry) {
        Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);

        badCdPtr = cdPtr;
        Tcl_AppendStringsToObj(resultPtr,
            "class \"", cdefnPtr->fullname, "\" inherits base class \"",
            badCdPtr->fullname, "\" more than once:",
            (char*)NULL);

        cdPtr = cdefnPtr;
        Itcl_InitStack(&stack);
        Itcl_PushStack((ClientData)cdPtr, &stack);

        /*
         *  Show paths leading to bad base class
         */
        while (Itcl_GetStackSize(&stack) > 0) {
            cdPtr = (ItclClass*)Itcl_PopStack(&stack);

            if (cdPtr == badCdPtr) {
                Tcl_AppendToObj(resultPtr, "\n  ", -1);
                for (i=0; i < Itcl_GetStackSize(&stack); i++) {
                    if (Itcl_GetStackValue(&stack, i) == NULL) {
                        cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1);
                        Tcl_AppendStringsToObj(resultPtr,
                            cdPtr->name, "->",
                            (char*)NULL);
                    }
                }
                Tcl_AppendToObj(resultPtr, badCdPtr->name, -1);
            }
            else if (!cdPtr) {
                (void)Itcl_PopStack(&stack);
            }
            else {
                elem = Itcl_LastListElem(&cdPtr->bases);
                if (elem) {
                    Itcl_PushStack((ClientData)cdPtr, &stack);
                    Itcl_PushStack((ClientData)NULL, &stack);
                    while (elem) {
                        Itcl_PushStack(Itcl_GetListValue(elem), &stack);
                        elem = Itcl_PrevListElem(elem);
                    }
                }
            }
        }
        Itcl_DeleteStack(&stack);
        goto inheritError;
    }

    /*
     *  At this point, everything looks good.
     *  Finish the installation of the base classes.  Update
     *  each base class to recognize the current class as a
     *  derived class.
     */
    elem = Itcl_FirstListElem(&cdefnPtr->bases);
    while (elem) {
        baseCdefnPtr = (ItclClass*)Itcl_GetListValue(elem);

        Itcl_AppendList(&baseCdefnPtr->derived, (ClientData)cdefnPtr);
        Itcl_PreserveData((ClientData)cdefnPtr);

        elem = Itcl_NextListElem(elem);
    }

    Tcl_PopCallFrame(interp);
    return TCL_OK;


    /*
     *  If the "inherit" list cannot be built properly, tear it
     *  down and return an error.
     */
inheritError:
    Tcl_PopCallFrame(interp);

    elem = Itcl_FirstListElem(&cdefnPtr->bases);
    while (elem) {
        Itcl_ReleaseData( Itcl_GetListValue(elem) );
        elem = Itcl_DeleteListElem(elem);
    }
    return TCL_ERROR;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassProtectionCmd()
 *
 *  Invoked by Tcl whenever the user issues a protection setting
 *  command like "public" or "private".  Creates commands and
 *  variables, and assigns a protection level to them.  Protection
 *  levels are defined as follows:
 *
 *    public    => accessible from any namespace
 *    protected => accessible from selected namespaces
 *    private   => accessible only in the namespace where it was defined
 *
 *  Handles the following syntax:
 *
 *    public <command> ?<arg> <arg>...?
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassProtectionCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* protection level (public/protected/private) */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData;

    int result;
    int oldLevel;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?");
        return TCL_ERROR;
    }

    oldLevel = Itcl_Protection(interp, pInfo->pLevel);

    if (objc == 2) {
      /* CYGNUS LOCAL - Fix for Tcl8.1 */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1
      result = Tcl_EvalObj(interp, objv[1], 0);
#else
      result = Tcl_EvalObj(interp, objv[1]);
#endif
      /* END CYGNUS LOCAL */
    } else {
        result = Itcl_EvalArgs(interp, objc-1, objv+1);
    }

    if (result == TCL_BREAK) {
        Tcl_SetResult(interp, "invoked \"break\" outside of a loop",
            TCL_STATIC);
        result = TCL_ERROR;
    }
    else if (result == TCL_CONTINUE) {
        Tcl_SetResult(interp, "invoked \"continue\" outside of a loop",
            TCL_STATIC);
        result = TCL_ERROR;
    }
    else if (result != TCL_OK) {
        char mesg[256], *token;
        token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        sprintf(mesg, "\n    (%.100s body line %d)", token, interp->errorLine);
        Tcl_AddErrorInfo(interp, mesg);
    }

    Itcl_Protection(interp, oldLevel);
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassConstructorCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "constructor" command is invoked to define the constructor
 *  for an object.  Handles the following syntax:
 *
 *      constructor <arglist> ?<init>? <body>
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassConstructorCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* info for all known objects */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObjectInfo *info = (ItclObjectInfo*)clientData;
    ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    char *name, *arglist, *body;

    if (objc < 3 || objc > 4) {
        Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body");
        return TCL_ERROR;
    }

    name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
    if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", name, "\" already defined in class \"",
            cdefnPtr->fullname, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  If there is an object initialization statement, pick this
     *  out and take the last argument as the constructor body.
     */
    arglist = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    if (objc == 3) {
        body = Tcl_GetStringFromObj(objv[2], (int*)NULL);
    } else {
        cdefnPtr->initCode = objv[2];
        Tcl_IncrRefCount(cdefnPtr->initCode);
        body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
    }

    if (Itcl_CreateMethod(interp, cdefnPtr, name, arglist, body) != TCL_OK) {
        return TCL_ERROR;
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassDestructorCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "destructor" command is invoked to define the destructor
 *  for an object.  Handles the following syntax:
 *
 *      destructor <body>
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_ClassDestructorCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* info for all known objects */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObjectInfo *info = (ItclObjectInfo*)clientData;
    ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);

    char *name, *body;

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "body");
        return TCL_ERROR;
    }

    name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
    body = Tcl_GetStringFromObj(objv[1], (int*)NULL);

    if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", name, "\" already defined in class \"",
            cdefnPtr->fullname, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    if (Itcl_CreateMethod(interp, cdefnPtr, name, (char*)NULL, body)
        != TCL_OK) {
        return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ClassMethodCmd()
 *
 *  Invoked by Tcl during the parsing of a class definition whenever
 *  the "method" command is invoked to define an object method.