Posted to tcl by apw at Sun Aug 19 11:11:49 GMT 2007view raw
- /* missing functions for Itcl to avoid including of tclInt.h */
- /* these functions exist but are NOT PUBLISHED */
- EXTERN int Tcl_PushCallFrame (Tcl_Interp * interp,
- Tcl_CallFrame * framePtr,
- Tcl_Namespace * nsPtr, int isProcCallFrame);
- EXTERN void Tcl_PopCallFrame (Tcl_Interp * interp);
- EXTERN void Tcl_GetVariableFullName (Tcl_Interp * interp,
- Tcl_Var variable, Tcl_Obj * objPtr);
- EXTERN Tcl_Var Tcl_FindNamespaceVar (Tcl_Interp * interp,
- CONST char * name, Tcl_Namespace * contextNsPtr, int flags);
- /* end of functions that exist but are NOT PUBLISHED */
- This is the include file for interfaces I would like to have in Tcl core
- The defines with _XXX are just there, if the interfaces do not go into the core
- /*---------------------------------------------------
- * itclMigrate2TclCore.h
- *---------------------------------------------------
- */
- /* here come the definitions for code which should be migrated to Tcl core */
- /* these functions DO NOT exist and are not published */
- typedef struct Tcl_Proc_ *Tcl_Proc;
- typedef struct Tcl_CallFrameInfo {
- Tcl_Namespace *nsPtr;
- int flags;
- int objc;
- Tcl_Obj *CONST *objv;
- Tcl_CallFrame CONST *callerPtr;
- Tcl_CallFrame CONST *callerVarPtr;
- int level;
- Tcl_Proc procPtr;
- ClientData clientData;
- #ifdef ARNULF_FOR_ITCL_CODE
- Tcl_Resolve *resolvePtr;
- #endif
- } Tcl_CallFrameInfo;
- typedef void (*Tcl_ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
- #define Tcl_GetOriginalCommand _Tcl_GetOriginalCommand
- #define Tcl_SetCallFrameResolver _Tcl_SetCallFrameResolver
- #define Tcl_GetNamespaceCommandTable _Tcl_GetNamespaceCommandTable
- #define Tcl_GetNamespaceChildTable _Tcl_GetNamespaceChildTable
- #define Tcl_GetCallFrameInfo _Tcl_GetCallFrameInfo
- #define Tcl_SetCallFrameInfo _Tcl_SetCallFrameInfo
- #define Tcl_InitRewriteEnsemble _Tcl_InitRewriteEnsemble
- #define Tcl_ResetRewriteEnsemble _Tcl_ResetRewriteEnsemble
- #define Tcl_CreateProc _Tcl_CreateProc
- #define Tcl_ProcDeleteProc _Tcl_ProcDeleteProc
- #define Tcl_GetObjInterpProc _Tcl_GetObjInterpProc
- #define Tcl_SetProcCmd _Tcl_SetProcCmd
- #define Tcl_SetNamespaceResolver _Tcl_SetNamespaceResolver
- #define Tcl_InvokeNamespaceProc _Tcl_InvokeNamespaceProc
- EXTERN Tcl_Command _Tcl_GetOriginalCommand(Tcl_Command command);
- EXTERN Tcl_HashTable *_Tcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr);
- EXTERN int _Tcl_SetCallFrameResolver(Tcl_Interp *interp,
- Tcl_Resolve *resolvePtr);
- EXTERN Tcl_HashTable *_Tcl_GetNamespaceCommandTable(Tcl_Namespace *nsPtr);
- EXTERN int _Tcl_GetCallFrameInfo(Tcl_Interp *interp,
- const Tcl_CallFrame *framePtr, Tcl_CallFrameInfo *infoPtr);
- EXTERN int _Tcl_SetCallFrameInfo(Tcl_Interp *interp,
- Tcl_CallFrame *framePtr, CONST Tcl_CallFrameInfo *infoPtr);
- EXTERN int _Tcl_InitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
- int numInserted, int objc, Tcl_Obj *const *objv);
- EXTERN void _Tcl_ResetRewriteEnsemble(Tcl_Interp *interp,
- int isRootEnsemble);
- EXTERN int _Tcl_CreateProc(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
- CONST char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr,
- Tcl_Proc *procPtrPtr);
- EXTERN void _Tcl_ProcDeleteProc(ClientData clientData);
- EXTERN void *_Tcl_GetObjInterpProc(void);
- EXTERN int _Tcl_SetNamespaceResolver(Tcl_Namespace *nsPtr,
- Tcl_Resolve *resolvePtr);
- EXTERN int _Tcl_InvokeNamespaceProc(Tcl_Interp *interp, Tcl_Proc proc,
- Tcl_Namespace *nsPtr, Tcl_Obj *namePtr, Tcl_ProcErrorProc errorProc,
- int objc, Tcl_Obj *const *objv);
- /* end migration code */
- That is the Implementation I have done for providing the interfaces above
- /*
- * ------------------------------------------------------------------------
- * PACKAGE: [incr Tcl]
- * DESCRIPTION: Object-Oriented Extensions to Tcl
- *
- * This file contains procedures that belong in the Tcl/Tk core.
- * Hopefully, they'll migrate there soon.
- *
- * ========================================================================
- * AUTHOR: Arnulf Wiedemann
- *
- * RCS: $Id: itclMigrate2Core.c,v 1.0 2007/07/20 12:09:56 wiede Exp $
- * ========================================================================
- * 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 <tcl.h>
- #include <tclInt.h>
- #include "itclMigrate2TclCore.h"
- int
- _Tcl_GetCallFrameInfo(
- Tcl_Interp *interp, /* Interpreter in which to look for */
- const Tcl_CallFrame *framePtr, /* if NULL use framePtr from interp */
- Tcl_CallFrameInfo *infoPtr) /* Where to store information */
- {
- CallFrame *myFramePtr = (CallFrame *)framePtr;
- if (infoPtr == NULL) {
- return TCL_ERROR;
- }
- if (myFramePtr == NULL) {
- if (interp == NULL) {
- return TCL_ERROR;
- }
- myFramePtr = ((Interp *)interp)->varFramePtr;
- }
- infoPtr->nsPtr = (Tcl_Namespace *)myFramePtr->nsPtr;
- infoPtr->flags = myFramePtr->isProcCallFrame;
- infoPtr->objc = myFramePtr->objc;
- infoPtr->objv = myFramePtr->objv;
- infoPtr->callerPtr = (Tcl_CallFrame *)myFramePtr->callerPtr;
- infoPtr->callerVarPtr = (Tcl_CallFrame *)myFramePtr->callerVarPtr;
- infoPtr->level = myFramePtr->level;
- infoPtr->procPtr = (Tcl_Proc)myFramePtr->procPtr;
- infoPtr->clientData = myFramePtr->clientData;
- #ifdef ARNULF_FOR_ITCL_CODE
- infoPtr->resolvePtr = myFramePtr->resolvePtr;
- #endif
- return TCL_OK;
- }
- int
- _Tcl_SetCallFrameInfo(
- Tcl_Interp *interp, /* Interpreter in which to look for */
- Tcl_CallFrame *framePtr, /* if NULL use framePtr from interp */
- CONST Tcl_CallFrameInfo *infoPtr) /* Where to find information */
- {
- CallFrame *myFramePtr = (CallFrame *)framePtr;
- if (infoPtr == NULL) {
- return TCL_ERROR;
- }
- if (myFramePtr == NULL) {
- if (interp == NULL) {
- return TCL_ERROR;
- }
- myFramePtr = ((Interp *)interp)->varFramePtr;
- }
- myFramePtr->nsPtr = (Namespace *)infoPtr->nsPtr;
- myFramePtr->isProcCallFrame = infoPtr->flags;
- myFramePtr->objc = infoPtr->objc;
- myFramePtr->objv = infoPtr->objv ;
- myFramePtr->procPtr = (Proc *)infoPtr->procPtr;
- myFramePtr->clientData = infoPtr->clientData;
- #ifdef ARNULF_FOR_ITCL_CODE
- myFramePtr->resolvePtr = infoPtr->resolvePtr;
- #endif
- return TCL_OK;
- }
- Tcl_Command
- _Tcl_GetOriginalCommand(
- Tcl_Command command)
- {
- return TclGetOriginalCommand(command);
- }
- int
- _Tcl_SetCallFrameResolver(
- Tcl_Interp *interp,
- Tcl_Resolve *resolvePtr)
- {
- Tcl_CallFrameInfo cfInfo;
- Tcl_GetCallFrameInfo(interp, NULL, &cfInfo);
- cfInfo.resolvePtr = resolvePtr;
- cfInfo.flags |= FRAME_HAS_RESOLVER;
- Tcl_SetCallFrameInfo(interp, NULL, &cfInfo);
- return TCL_OK;
- }
- Tcl_HashTable *
- _Tcl_GetNamespaceCommandTable(
- Tcl_Namespace *nsPtr)
- {
- return &((Namespace *)nsPtr)->cmdTable;
- }
- Tcl_HashTable *
- _Tcl_GetNamespaceChildTable(
- Tcl_Namespace *nsPtr)
- {
- return &((Namespace *)nsPtr)->childTable;
- }
- int
- _Tcl_InitRewriteEnsemble(
- Tcl_Interp *interp,
- int numRemoved,
- int numInserted,
- int objc,
- Tcl_Obj *const *objv)
- {
- Interp *iPtr = (Interp *) interp;
- int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = objv;
- iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
- iPtr->ensembleRewrite.numInsertedObjs = numInserted;
- } else {
- int numIns = iPtr->ensembleRewrite.numInsertedObjs;
- if (numIns < numRemoved) {
- iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
- iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1;
- } else {
- iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
- }
- }
- return isRootEnsemble;
- }
- void
- _Tcl_ResetRewriteEnsemble(
- Tcl_Interp *interp,
- int isRootEnsemble)
- {
- Interp *iPtr = (Interp *) interp;
- if (isRootEnsemble) {
- iPtr->ensembleRewrite.sourceObjs = NULL;
- iPtr->ensembleRewrite.numRemovedObjs = 0;
- iPtr->ensembleRewrite.numInsertedObjs = 0;
- }
- }
- int
- _Tcl_CreateProc(
- Tcl_Interp *interp, /* Interpreter containing proc. */
- Tcl_Namespace *nsPtr, /* Namespace containing this proc. */
- CONST char *procName, /* Unqualified name of this proc. */
- Tcl_Obj *argsPtr, /* Description of arguments. */
- Tcl_Obj *bodyPtr, /* Command body. */
- Tcl_Proc *procPtrPtr) /* Returns: pointer to proc data. */
- {
- return TclCreateProc(interp, (Namespace *)nsPtr, procName, argsPtr,
- bodyPtr, (Proc **)procPtrPtr);
- }
- void *
- _Tcl_GetObjInterpProc(
- void)
- {
- return (void *)TclGetObjInterpProc();
- }
- int
- _Tcl_SetNamespaceResolver(
- Tcl_Namespace *nsPtr,
- Tcl_Resolve *resolvePtr)
- {
- if (nsPtr == NULL) {
- return TCL_ERROR;
- }
- ((Namespace *)nsPtr)->resolvePtr = resolvePtr;
- return TCL_OK;
- }
- void
- _Tcl_ProcDeleteProc(
- ClientData clientData)
- {
- TclProcDeleteProc(clientData);
- }
- int
- _Tcl_InvokeNamespaceProc(
- Tcl_Interp *interp,
- Tcl_Proc proc,
- Tcl_Namespace *nsPtr,
- Tcl_Obj *namePtr,
- Tcl_ProcErrorProc errorProc,
- int objc,
- Tcl_Obj *const *objv)
- {
- CallFrame frame;
- CallFrame *framePtr = &frame;
- Command cmd;
- Proc *procPtr = (Proc *)proc;
- int flags = 0;;
- int result;
- memset(&cmd, 0, sizeof(Command));
- cmd.nsPtr = (Namespace *) nsPtr;
- cmd.clientData = NULL;
- procPtr->cmdPtr = &cmd;
- result = TclProcCompileProc(interp, procPtr,
- procPtr->bodyPtr, (Namespace *) nsPtr, "body of method",
- Tcl_GetString(namePtr));
- if (result != TCL_OK) {
- return result;
- }
- /*
- * Make the stack frame and fill it out with information about this call.
- * This operation may fail.
- */
- flags |= FRAME_IS_PROC;
- result = TclPushStackFrame(interp, &framePtr, nsPtr, flags);
- if (result != TCL_OK) {
- return result;
- }
- framePtr->clientData = NULL;
- framePtr->objc = objc;
- framePtr->objv = objv;
- framePtr->procPtr = procPtr;
- /*
- * Now invoke the body of the method. Note that we need to take special
- * action when doing unknown processing to ensure that the missing method
- * name is passed as an argument.
- */
- result = TclObjInterpProcCore(interp, namePtr, 1, errorProc);
- return result;
- }