📄 itcl_parse.c
字号:
/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * Procedures in this file support the new syntax for [incr Tcl] * class definitions: * * itcl_class <className> { * inherit <base-class>... * * constructor {<arglist>} ?{<init>}? {<body>} * destructor {<body>} * * method <name> {<arglist>} {<body>} * proc <name> {<arglist>} {<body>} * variable <name> ?<init>? ?<config>? * common <name> ?<init>? * * public <thing> ?<args>...? * protected <thing> ?<args>...? * private <thing> ?<args>...? * } * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * RCS: $Id: itcl_parse.c 144 2003-02-05 10:56:26Z mdejong $ * ======================================================================== * Copyright (c) 1993-1998 Lucent Technologies, Inc. * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */#include "itclInt.h"/* * Info needed for public/protected/private commands: */typedef struct ProtectionCmdInfo { int pLevel; /* protection level */ ItclObjectInfo *info; /* info regarding all known objects */} ProtectionCmdInfo;/* * FORWARD DECLARATIONS */static void ItclFreeParserCommandData _ANSI_ARGS_((char* cdata)); /* * ------------------------------------------------------------------------ * Itcl_ParseInit() * * Invoked by Itcl_Init() whenever a new interpeter is created to add * [incr Tcl] facilities. Adds the commands needed to parse class * definitions. * ------------------------------------------------------------------------ */intItcl_ParseInit(interp, info) Tcl_Interp *interp; /* interpreter to be updated */ ItclObjectInfo *info; /* info regarding all known objects */{ Tcl_Namespace *parserNs; ProtectionCmdInfo *pInfo; /* * Create the "itcl::parser" namespace used to parse class * definitions. */ parserNs = Tcl_CreateNamespace(interp, "::itcl::parser", (ClientData)info, Itcl_ReleaseData); if (!parserNs) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " (cannot initialize itcl parser)", (char*)NULL); return TCL_ERROR; } Itcl_PreserveData((ClientData)info); /* * Add commands for parsing class definitions. */ Tcl_CreateObjCommand(interp, "::itcl::parser::inherit", Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::constructor", Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::destructor", Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::method", Itcl_ClassMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::proc", Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::common", Itcl_ClassCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::variable", Itcl_ClassVariableCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfo->pLevel = ITCL_PUBLIC; pInfo->info = info; Tcl_CreateObjCommand(interp, "::itcl::parser::public", Itcl_ClassProtectionCmd, (ClientData)pInfo, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfo->pLevel = ITCL_PROTECTED; pInfo->info = info; Tcl_CreateObjCommand(interp, "::itcl::parser::protected", Itcl_ClassProtectionCmd, (ClientData)pInfo, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfo->pLevel = ITCL_PRIVATE; pInfo->info = info; Tcl_CreateObjCommand(interp, "::itcl::parser::private", Itcl_ClassProtectionCmd, (ClientData)pInfo, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); /* * Set the runtime variable resolver for the parser namespace, * to control access to "common" data members while parsing * the class definition. */ Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL, Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); /* * Install the "class" command for defining new classes. */ Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, (ClientData)info, Itcl_ReleaseData); Itcl_PreserveData((ClientData)info); return TCL_OK;} /* * ------------------------------------------------------------------------ * Itcl_ClassCmd() * * Invoked by Tcl whenever the user issues an "itcl::class" command to * specify a class definition. Handles the following syntax: * * itcl::class <className> { * inherit <base-class>... * * constructor {<arglist>} ?{<init>}? {<body>} * destructor {<body>} * * method <name> {<arglist>} {<body>} * proc <name> {<arglist>} {<body>} * variable <varname> ?<init>? ?<config>? * common <varname> ?<init>? * * public <args>... * protected <args>... * private <args>... * } * * ------------------------------------------------------------------------ */intItcl_ClassCmd(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; int result; char *className; Tcl_Namespace *parserNs; ItclClass *cdefnPtr; Tcl_CallFrame frame; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); return TCL_ERROR; } className = Tcl_GetStringFromObj(objv[1], (int*)NULL); /* * Find the namespace to use as a parser for the class definition. * If for some reason it is destroyed, bail out here. */ parserNs = Tcl_FindNamespace(interp, "::itcl::parser", (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (parserNs == NULL) { char msg[256]; sprintf(msg, "\n (while parsing class definition for \"%.100s\")", className); Tcl_AddErrorInfo(interp, msg); return TCL_ERROR; } /* * Try to create the specified class and its namespace. */ if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) { return TCL_ERROR; } /* * Import the built-in commands from the itcl::builtin namespace. * Do this before parsing the class definition, so methods/procs * can override the built-in commands. */ result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*", /* allowOverwrite */ 1); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className); Tcl_AddErrorInfo(interp, msg); Tcl_DeleteNamespace(cdefnPtr->namesp); return TCL_ERROR; } /* * Push this class onto the class definition stack so that it * becomes the current context for all commands in the parser. * Activate the parser and evaluate the class definition. */ Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack); result = Tcl_PushCallFrame(interp, &frame, parserNs, /* isProcCallFrame */ 0); if (result == TCL_OK) { /* CYGNUS LOCAL - Fix for Tcl8.1 */#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 result = Tcl_EvalObj(interp, objv[2], 0);#else result = Tcl_EvalObj(interp, objv[2]);#endif /* END CYGNUS LOCAL */ Tcl_PopCallFrame(interp); } Itcl_PopStack(&info->cdefnStack); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (class \"%.200s\" body line %d)", className, interp->errorLine); Tcl_AddErrorInfo(interp, msg); Tcl_DeleteNamespace(cdefnPtr->namesp); return TCL_ERROR; } /* * At this point, parsing of the class definition has succeeded. * Add built-in methods such as "configure" and "cget"--as long * as they don't conflict with those defined in the class. */ if (Itcl_InstallBiMethods(interp, cdefnPtr) != TCL_OK) { Tcl_DeleteNamespace(cdefnPtr->namesp); return TCL_ERROR; } /* * Build the name resolution tables for all data members. */ Itcl_BuildVirtualTables(cdefnPtr); Tcl_ResetResult(interp); return TCL_OK;} /* * ------------------------------------------------------------------------ * Itcl_ClassInheritCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "inherit" command is invoked to define one or more base classes. * Handles the following syntax: * * inherit <baseclass> ?<baseclass>...? * * ------------------------------------------------------------------------ */intItcl_ClassInheritCmd(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); int result, i, newEntry; char *token; Itcl_ListElem *elem, *elem2; ItclClass *cdPtr, *baseCdefnPtr, *badCdPtr; ItclHierIter hier; Itcl_Stack stack; Tcl_CallFrame frame; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?"); return TCL_ERROR; } /* * In "inherit" statement can only be included once in a * class definition. */ elem = Itcl_FirstListElem(&cdefnPtr->bases); if (elem != NULL) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1); while (elem) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), cdPtr->name, " ", (char*)NULL); elem = Itcl_NextListElem(elem); } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\" already defined for class \"", cdefnPtr->fullname, "\"", (char*)NULL); return TCL_ERROR; } /* * Validate each base class and add it to the "bases" list. */ result = Tcl_PushCallFrame(interp, &frame, cdefnPtr->namesp->parentPtr, /* isProcCallFrame */ 0); if (result != TCL_OK) { return TCL_ERROR;⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -