← Back to branch summary

~ubuntu-branches/debian/sid/itcl4/sid

« back to all changes in this revision

Viewing changes to generic/itclMigrate2TclCore.c

  • Committer: Package Import Robot
  • Author(s): Sergei Golovan
  • Date: 2018-03-06 11:36:54 UTC
  • Revision ID: package-import@ubuntu.com-20180306113654-w3oht8cjhtftrxby
Tags: upstream-4.1.1
Import upstream version 4.1.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
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
#endif
 
32
        return TCL_OK;
 
33
    }
 
34
    return TCL_ERROR;
 
35
}
 
36
 
 
37
int
 
38
_Tcl_SetNamespaceResolver(
 
39
    Tcl_Namespace *nsPtr,
 
40
    Tcl_Resolve *resolvePtr)
 
41
{
 
42
    if (nsPtr == NULL) {
 
43
        return TCL_ERROR;
 
44
    }
 
45
#ifdef ITCL_USE_MODIFIED_TCL_H
 
46
    ((Namespace *)nsPtr)->resolvePtr = resolvePtr;
 
47
#endif
 
48
    return TCL_OK;
 
49
}
 
50
 
 
51
Tcl_Var
 
52
Tcl_NewNamespaceVar(
 
53
    Tcl_Interp *interp,
 
54
    Tcl_Namespace *nsPtr,
 
55
    const char *varName)
 
56
{
 
57
    Var *varPtr = NULL;
 
58
    int new;
 
59
 
 
60
    if ((nsPtr == NULL) || (varName == NULL)) {
 
61
        return NULL;
 
62
    }
 
63
 
 
64
    varPtr = TclVarHashCreateVar(&((Namespace *)nsPtr)->varTable,
 
65
            varName, &new);
 
66
    TclSetVarNamespaceVar(varPtr);
 
67
    return (Tcl_Var)varPtr;
 
68
}
 
69
 
 
70
void
 
71
Itcl_PreserveVar(
 
72
    Tcl_Var var)
 
73
{
 
74
    Var *varPtr = (Var *)var;
 
75
 
 
76
    VarHashRefCount(varPtr)++;
 
77
}
 
78
 
 
79
void
 
80
Itcl_ReleaseVar(
 
81
    Tcl_Var var)
 
82
{
 
83
    Var *varPtr = (Var *)var;
 
84
 
 
85
    VarHashRefCount(varPtr)--;
 
86
    TclCleanupVar(varPtr, NULL);
 
87
}
 
88
 
 
89
Tcl_CallFrame *
 
90
Itcl_GetUplevelCallFrame(
 
91
    Tcl_Interp *interp,
 
92
    int level)
 
93
{
 
94
    CallFrame *framePtr;
 
95
    if (level < 0) {
 
96
        return NULL;
 
97
    }
 
98
    framePtr = ((Interp *)interp)->varFramePtr;
 
99
    while ((framePtr != NULL) && (level-- > 0)) {
 
100
        framePtr = framePtr->callerVarPtr;
 
101
    }
 
102
    if (framePtr == NULL) {
 
103
        return NULL;
 
104
    }
 
105
    return (Tcl_CallFrame *)framePtr;
 
106
}
 
107
 
 
108
Tcl_CallFrame *
 
109
Itcl_ActivateCallFrame(
 
110
    Tcl_Interp *interp,
 
111
    Tcl_CallFrame *framePtr)
 
112
{
 
113
    Interp *iPtr = (Interp*)interp;
 
114
    CallFrame *oldFramePtr;
 
115
 
 
116
    oldFramePtr = iPtr->varFramePtr;
 
117
    iPtr->varFramePtr = (CallFrame *) framePtr;
 
118
 
 
119
    return (Tcl_CallFrame *) oldFramePtr;
 
120
}
 
121
 
 
122
Tcl_Namespace *
 
123
Itcl_GetUplevelNamespace(
 
124
    Tcl_Interp *interp,
 
125
    int level)
 
126
{
 
127
    CallFrame *framePtr;
 
128
    if (level < 0) {
 
129
        return NULL;
 
130
    }
 
131
    framePtr = ((Interp *)interp)->framePtr;
 
132
    while ((framePtr != NULL) && (level-- > 0)) {
 
133
        framePtr = framePtr->callerVarPtr;
 
134
    }
 
135
    if (framePtr == NULL) {
 
136
        return NULL;
 
137
    }
 
138
    return (Tcl_Namespace *)framePtr->nsPtr;
 
139
}
 
140
 
 
141
ClientData
 
142
Itcl_GetCallFrameClientData(
 
143
    Tcl_Interp *interp)
 
144
{
 
145
    /* suggested fix for SF bug #250 use varFramePtr instead of framePtr
 
146
     * seems to have no side effect concerning test suite, but does NOT fix the bug
 
147
     */
 
148
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 
149
    if (framePtr == NULL) {
 
150
        return NULL;
 
151
    }
 
152
    return framePtr->clientData;
 
153
}
 
154
 
 
155
int
 
156
Itcl_SetCallFrameNamespace(
 
157
    Tcl_Interp *interp,
 
158
    Tcl_Namespace *nsPtr)
 
159
{
 
160
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 
161
    if (framePtr == NULL) {
 
162
        return TCL_ERROR;
 
163
    }
 
164
    ((Interp *)interp)->varFramePtr->nsPtr = (Namespace *)nsPtr;
 
165
    return TCL_OK;
 
166
}
 
167
 
 
168
int
 
169
Itcl_GetCallVarFrameObjc(
 
170
    Tcl_Interp *interp)
 
171
{
 
172
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 
173
    if (framePtr == NULL) {
 
174
        return 0;
 
175
    }
 
176
    return framePtr->objc;
 
177
}
 
178
 
 
179
Tcl_Obj * const *
 
180
Itcl_GetCallVarFrameObjv(
 
181
    Tcl_Interp *interp)
 
182
{
 
183
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
 
184
    if (framePtr == NULL) {
 
185
        return NULL;
 
186
    }
 
187
    return framePtr->objv;
 
188
}
 
189
 
 
190
int
 
191
Itcl_GetCallFrameObjc(
 
192
    Tcl_Interp *interp)
 
193
{
 
194
    CallFrame *framePtr = ((Interp *)interp)->framePtr;
 
195
    if (framePtr == NULL) {
 
196
        return 0;
 
197
    }
 
198
    return ((Interp *)interp)->framePtr->objc;
 
199
}
 
200
 
 
201
Tcl_Obj * const *
 
202
Itcl_GetCallFrameObjv(
 
203
    Tcl_Interp *interp)
 
204
{
 
205
    CallFrame *framePtr = ((Interp *)interp)->framePtr;
 
206
    if (framePtr == NULL) {
 
207
        return NULL;
 
208
    }
 
209
    return ((Interp *)interp)->framePtr->objv;
 
210
}
 
211
 
 
212
int
 
213
Itcl_IsCallFrameArgument(
 
214
    Tcl_Interp *interp,
 
215
    const char *name)
 
216
{
 
217
    CallFrame *varFramePtr = ((Interp *)interp)->framePtr;
 
218
    Proc *procPtr;
 
219
 
 
220
    if (varFramePtr == NULL) {
 
221
        return 0;
 
222
    }
 
223
    if (!varFramePtr->isProcCallFrame) {
 
224
        return 0;
 
225
    }
 
226
    procPtr = varFramePtr->procPtr;
 
227
    /*
 
228
     *  Search through compiled locals first...
 
229
     */
 
230
    if (procPtr) {
 
231
        CompiledLocal *localPtr = procPtr->firstLocalPtr;
 
232
        int nameLen = strlen(name);
 
233
 
 
234
        for (;localPtr != NULL; localPtr = localPtr->nextPtr) {
 
235
            if (TclIsVarArgument(localPtr)) {
 
236
                register char *localName = localPtr->name;
 
237
                if ((name[0] == localName[0])
 
238
                        && (nameLen == localPtr->nameLength)
 
239
                        && (strcmp(name, localName) == 0)) {
 
240
                    return 1;
 
241
                }
 
242
            }
 
243
        }
 
244
    }
 
245
    return 0;
 
246
}
 
247
 
 
248
int
 
249
Itcl_IsCallFrameLinkVar(
 
250
    Tcl_Interp *interp,
 
251
    const char *name)
 
252
{
 
253
    CallFrame *varFramePtr = ((Interp *)interp)->framePtr;
 
254
    Proc *procPtr;
 
255
 
 
256
    if (varFramePtr == NULL) {
 
257
        return 0;
 
258
    }
 
259
    if (!varFramePtr->isProcCallFrame) {
 
260
        return 0;
 
261
    }
 
262
    procPtr = varFramePtr->procPtr;
 
263
    /*
 
264
     *  Search through compiled locals first...
 
265
     */
 
266
    if (procPtr) {
 
267
        CompiledLocal *localPtr = procPtr->firstLocalPtr;
 
268
        int nameLen = strlen(name);
 
269
 
 
270
        for (;localPtr != NULL; localPtr = localPtr->nextPtr) {
 
271
            if (TclIsVarLink(localPtr)) {
 
272
                register char *localName = localPtr->name;
 
273
                if ((name[0] == localName[0])
 
274
                        && (nameLen == localPtr->nameLength)
 
275
                        && (strcmp(name, localName) == 0)) {
 
276
                    return 1;
 
277
                }
 
278
            }
 
279
        }
 
280
    }
 
281
    return 0;
 
282
}
 
283
 
 
284
int 
 
285
Itcl_IsVarLink(Tcl_Var varPtr) {
 
286
    return TclIsVarLink((Var *)varPtr);
 
287
}