util/src/TclTk/tcl8.6.12/pkgs/itcl4.2.2/generic/itclMigrate2TclCore.c

   1 /*
   2  * ------------------------------------------------------------------------
   3  *      PACKAGE:  [incr Tcl]
   4  *  DESCRIPTION:  Object-Oriented Extensions to Tcl
   5  *
   6  *  This file contains procedures that belong in the Tcl/Tk core.
   7  *  Hopefully, they'll migrate there soon.
   8  *
   9  * ========================================================================
  10  *  AUTHOR:  Arnulf Wiedemann
  11  *
  12  * ========================================================================
  13  *           Copyright (c) 1993-1998  Lucent Technologies, Inc.
  14  * ------------------------------------------------------------------------
  15  * See the file "license.terms" for information on usage and redistribution
  16  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  17  */
  18 #include <tclInt.h>
  19 #include "itclInt.h"
  20
  21 int
  22 Itcl_SetCallFrameResolver(
  23     Tcl_Interp *interp,
  24     Tcl_Resolve *resolvePtr)
  25 {
  26     CallFrame *framePtr = ((Interp *)interp)->framePtr;
  27     if (framePtr != NULL) {
  28 #ifdef ITCL_USE_MODIFIED_TCL_H
  29         framePtr->isProcCallFrame |= FRAME_HAS_RESOLVER;
  30         framePtr->resolvePtr = resolvePtr;
  31 #elif defined(__cplusplus)
  32         (void)resolvePtr;
  33 #endif
  34         return TCL_OK;
  35     }
  36     return TCL_ERROR;
  37 }
  38
  39 int
  40 _Tcl_SetNamespaceResolver(
  41     Tcl_Namespace *nsPtr,
  42     Tcl_Resolve *resolvePtr)
  43 {
  44     if (nsPtr == NULL) {
  45         return TCL_ERROR;
  46     }
  47 #ifdef ITCL_USE_MODIFIED_TCL_H
  48     ((Namespace *)nsPtr)->resolvePtr = resolvePtr;
  49 #elif defined(__cplusplus)
  50     (void)resolvePtr;
  51 #endif
  52     return TCL_OK;
  53 }
  54
  55 Tcl_Var
  56 Tcl_NewNamespaceVar(
  57     TCL_UNUSED(Tcl_Interp *),
  58     Tcl_Namespace *nsPtr,
  59     const char *varName)
  60 {
  61     Var *varPtr = NULL;
  62     int isNew;
  63
  64     if ((nsPtr == NULL) || (varName == NULL)) {
  65         return NULL;
  66     }
  67
  68     varPtr = TclVarHashCreateVar(&((Namespace *)nsPtr)->varTable,
  69             varName, &isNew);
  70     TclSetVarNamespaceVar(varPtr);
  71     return (Tcl_Var)varPtr;
  72 }
  73
  74 void
  75 Itcl_PreserveVar(
  76     Tcl_Var var)
  77 {
  78     Var *varPtr = (Var *)var;
  79
  80     VarHashRefCount(varPtr)++;
  81 }
  82
  83 void
  84 Itcl_ReleaseVar(
  85     Tcl_Var var)
  86 {
  87     Var *varPtr = (Var *)var;
  88
  89     VarHashRefCount(varPtr)--;
  90     TclCleanupVar(varPtr, NULL);
  91 }
  92
  93 Tcl_CallFrame *
  94 Itcl_GetUplevelCallFrame(
  95     Tcl_Interp *interp,
  96     int level)
  97 {
  98     CallFrame *framePtr;
  99     if (level < 0) {
 100         return NULL;
 101     }
 102     framePtr = ((Interp *)interp)->varFramePtr;
 103     while ((framePtr != NULL) && (level-- > 0)) {
 104         framePtr = framePtr->callerVarPtr;
 105     }
 106     if (framePtr == NULL) {
 107         return NULL;
 108     }
 109     return (Tcl_CallFrame *)framePtr;
 110 }
 111
 112 Tcl_CallFrame *
 113 Itcl_ActivateCallFrame(
 114     Tcl_Interp *interp,
 115     Tcl_CallFrame *framePtr)
 116 {
 117     Interp *iPtr = (Interp*)interp;
 118     CallFrame *oldFramePtr;
 119
 120     oldFramePtr = iPtr->varFramePtr;
 121     iPtr->varFramePtr = (CallFrame *) framePtr;
 122
 123     return (Tcl_CallFrame *) oldFramePtr;
 124 }
 125
 126 Tcl_Namespace *
 127 Itcl_GetUplevelNamespace(
 128     Tcl_Interp *interp,
 129     int level)
 130 {
 131     CallFrame *framePtr;
 132     if (level < 0) {
 133         return NULL;
 134     }
 135     framePtr = ((Interp *)interp)->framePtr;
 136     while ((framePtr != NULL) && (level-- > 0)) {
 137         framePtr = framePtr->callerVarPtr;
 138     }
 139     if (framePtr == NULL) {
 140         return NULL;
 141     }
 142     return (Tcl_Namespace *)framePtr->nsPtr;
 143 }
 144
 145 ClientData
 146 Itcl_GetCallFrameClientData(
 147     Tcl_Interp *interp)
 148 {
 149     /* suggested fix for SF bug #250 use varFramePtr instead of framePtr
 150      * seems to have no side effect concerning test suite, but does NOT fix the bug
 151      */
 152     CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 153     if (framePtr == NULL) {
 154         return NULL;
 155     }
 156     return framePtr->clientData;
 157 }
 158
 159 int
 160 Itcl_SetCallFrameNamespace(
 161     Tcl_Interp *interp,
 162     Tcl_Namespace *nsPtr)
 163 {
 164     CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 165     if (framePtr == NULL) {
 166         return TCL_ERROR;
 167     }
 168     ((Interp *)interp)->varFramePtr->nsPtr = (Namespace *)nsPtr;
 169     return TCL_OK;
 170 }
 171
 172 int
 173 Itcl_GetCallVarFrameObjc(
 174     Tcl_Interp *interp)
 175 {
 176     CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 177     if (framePtr == NULL) {
 178         return 0;
 179     }
 180     return framePtr->objc;
 181 }
 182
 183 Tcl_Obj * const *
 184 Itcl_GetCallVarFrameObjv(
 185     Tcl_Interp *interp)
 186 {
 187     CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 188     if (framePtr == NULL) {
 189         return NULL;
 190     }
 191     return framePtr->objv;
 192 }
 193
 194 int
 195 Itcl_GetCallFrameObjc(
 196     Tcl_Interp *interp)
 197 {
 198     CallFrame *framePtr = ((Interp *)interp)->framePtr;
 199     if (framePtr == NULL) {
 200         return 0;
 201     }
 202     return ((Interp *)interp)->framePtr->objc;
 203 }
 204
 205 Tcl_Obj * const *
 206 Itcl_GetCallFrameObjv(
 207     Tcl_Interp *interp)
 208 {
 209     CallFrame *framePtr = ((Interp *)interp)->framePtr;
 210     if (framePtr == NULL) {
 211         return NULL;
 212     }
 213     return ((Interp *)interp)->framePtr->objv;
 214 }
 215
 216 int
 217 Itcl_IsCallFrameArgument(
 218     Tcl_Interp *interp,
 219     const char *name)
 220 {
 221     CallFrame *varFramePtr = ((Interp *)interp)->framePtr;
 222     Proc *procPtr;
 223
 224     if (varFramePtr == NULL) {
 225         return 0;
 226     }
 227     if (!varFramePtr->isProcCallFrame) {
 228         return 0;
 229     }
 230     procPtr = varFramePtr->procPtr;
 231     /*
 232      *  Search through compiled locals first...
 233      */
 234     if (procPtr) {
 235         CompiledLocal *localPtr = procPtr->firstLocalPtr;
 236         int nameLen = strlen(name);
 237
 238         for (;localPtr != NULL; localPtr = localPtr->nextPtr) {
 239             if (TclIsVarArgument(localPtr)) {
 240                 char *localName = localPtr->name;
 241                 if ((name[0] == localName[0])
 242                         && (nameLen == localPtr->nameLength)
 243                         && (strcmp(name, localName) == 0)) {
 244                     return 1;
 245                 }
 246             }
 247         }
 248     }
 249     return 0;
 250 }