/[dtapublic]/projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclresolve.c
ViewVC logotype

Annotation of /projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclresolve.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 98 - (hide annotations) (download)
Sun Dec 18 00:57:31 2016 UTC (7 years, 7 months ago) by dashley
File MIME type: text/plain
File size: 14056 byte(s)
Reorganization.
1 dashley 71 /* $Header$ */
2     /*
3     * tclResolve.c --
4     *
5     * Contains hooks for customized command/variable name resolution
6     * schemes. These hooks allow extensions like [incr Tcl] to add
7     * their own name resolution rules to the Tcl language. Rules can
8     * be applied to a particular namespace, to the interpreter as a
9     * whole, or both.
10     *
11     * Copyright (c) 1998 Lucent Technologies, Inc.
12     *
13     * See the file "license.terms" for information on usage and redistribution
14     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15     *
16     * RCS: @(#) $Id: tclresolve.c,v 1.1.1.1 2001/06/13 04:45:45 dtashley Exp $
17     */
18    
19     #include "tclInt.h"
20    
21     /*
22     * Declarations for procedures local to this file:
23     */
24    
25     static void BumpCmdRefEpochs _ANSI_ARGS_((Namespace *nsPtr));
26    
27    
28     /*
29     *----------------------------------------------------------------------
30     *
31     * Tcl_AddInterpResolvers --
32     *
33     * Adds a set of command/variable resolution procedures to an
34     * interpreter. These procedures are consulted when commands
35     * are resolved in Tcl_FindCommand, and when variables are
36     * resolved in TclLookupVar and LookupCompiledLocal. Each
37     * namespace may also have its own set of resolution procedures
38     * which take precedence over those for the interpreter.
39     *
40     * When a name is resolved, it is handled as follows. First,
41     * the name is passed to the resolution procedures for the
42     * namespace. If not resolved, the name is passed to each of
43     * the resolution procedures added to the interpreter. Finally,
44     * if still not resolved, the name is handled using the default
45     * Tcl rules for name resolution.
46     *
47     * Results:
48     * Returns pointers to the current name resolution procedures
49     * in the cmdProcPtr, varProcPtr and compiledVarProcPtr
50     * arguments.
51     *
52     * Side effects:
53     * If a compiledVarProc is specified, this procedure bumps the
54     * compileEpoch for the interpreter, forcing all code to be
55     * recompiled. If a cmdProc is specified, this procedure bumps
56     * the cmdRefEpoch in all namespaces, forcing commands to be
57     * resolved again using the new rules.
58     *
59     *----------------------------------------------------------------------
60     */
61    
62     void
63     Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc)
64    
65     Tcl_Interp *interp; /* Interpreter whose name resolution
66     * rules are being modified. */
67     char *name; /* Name of this resolution scheme. */
68     Tcl_ResolveCmdProc *cmdProc; /* New procedure for command
69     * resolution */
70     Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution
71     * at runtime */
72     Tcl_ResolveCompiledVarProc *compiledVarProc;
73     /* Procedure for variable resolution
74     * at compile time. */
75     {
76     Interp *iPtr = (Interp*)interp;
77     ResolverScheme *resPtr;
78    
79     /*
80     * Since we're adding a new name resolution scheme, we must force
81     * all code to be recompiled to use the new scheme. If there
82     * are new compiled variable resolution rules, bump the compiler
83     * epoch to invalidate compiled code. If there are new command
84     * resolution rules, bump the cmdRefEpoch in all namespaces.
85     */
86     if (compiledVarProc) {
87     iPtr->compileEpoch++;
88     }
89     if (cmdProc) {
90     BumpCmdRefEpochs(iPtr->globalNsPtr);
91     }
92    
93     /*
94     * Look for an existing scheme with the given name. If found,
95     * then replace its rules.
96     */
97     for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
98     if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
99     resPtr->cmdResProc = cmdProc;
100     resPtr->varResProc = varProc;
101     resPtr->compiledVarResProc = compiledVarProc;
102     return;
103     }
104     }
105    
106     /*
107     * Otherwise, this is a new scheme. Add it to the FRONT
108     * of the linked list, so that it overrides existing schemes.
109     */
110     resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
111     resPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1));
112     strcpy(resPtr->name, name);
113     resPtr->cmdResProc = cmdProc;
114     resPtr->varResProc = varProc;
115     resPtr->compiledVarResProc = compiledVarProc;
116     resPtr->nextPtr = iPtr->resolverPtr;
117     iPtr->resolverPtr = resPtr;
118     }
119    
120     /*
121     *----------------------------------------------------------------------
122     *
123     * Tcl_GetInterpResolvers --
124     *
125     * Looks for a set of command/variable resolution procedures with
126     * the given name in an interpreter. These procedures are
127     * registered by calling Tcl_AddInterpResolvers.
128     *
129     * Results:
130     * If the name is recognized, this procedure returns non-zero,
131     * along with pointers to the name resolution procedures in
132     * the Tcl_ResolverInfo structure. If the name is not recognized,
133     * this procedure returns zero.
134     *
135     * Side effects:
136     * None.
137     *
138     *----------------------------------------------------------------------
139     */
140    
141     int
142     Tcl_GetInterpResolvers(interp, name, resInfoPtr)
143    
144     Tcl_Interp *interp; /* Interpreter whose name resolution
145     * rules are being queried. */
146     char *name; /* Look for a scheme with this name. */
147     Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the procedures,
148     * if found */
149     {
150     Interp *iPtr = (Interp*)interp;
151     ResolverScheme *resPtr;
152    
153     /*
154     * Look for an existing scheme with the given name. If found,
155     * then return pointers to its procedures.
156     */
157     for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
158     if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
159     resInfoPtr->cmdResProc = resPtr->cmdResProc;
160     resInfoPtr->varResProc = resPtr->varResProc;
161     resInfoPtr->compiledVarResProc = resPtr->compiledVarResProc;
162     return 1;
163     }
164     }
165    
166     return 0;
167     }
168    
169     /*
170     *----------------------------------------------------------------------
171     *
172     * Tcl_RemoveInterpResolvers --
173     *
174     * Removes a set of command/variable resolution procedures
175     * previously added by Tcl_AddInterpResolvers. The next time
176     * a command/variable name is resolved, these procedures
177     * won't be consulted.
178     *
179     * Results:
180     * Returns non-zero if the name was recognized and the
181     * resolution scheme was deleted. Returns zero otherwise.
182     *
183     * Side effects:
184     * If a scheme with a compiledVarProc was deleted, this procedure
185     * bumps the compileEpoch for the interpreter, forcing all code
186     * to be recompiled. If a scheme with a cmdProc was deleted,
187     * this procedure bumps the cmdRefEpoch in all namespaces,
188     * forcing commands to be resolved again using the new rules.
189     *
190     *----------------------------------------------------------------------
191     */
192    
193     int
194     Tcl_RemoveInterpResolvers(interp, name)
195    
196     Tcl_Interp *interp; /* Interpreter whose name resolution
197     * rules are being modified. */
198     char *name; /* Name of the scheme to be removed. */
199     {
200     Interp *iPtr = (Interp*)interp;
201     ResolverScheme **prevPtrPtr, *resPtr;
202    
203     /*
204     * Look for an existing scheme with the given name.
205     */
206     prevPtrPtr = &iPtr->resolverPtr;
207     for (resPtr = iPtr->resolverPtr; resPtr != NULL; resPtr = resPtr->nextPtr) {
208     if (*name == *resPtr->name && strcmp(name, resPtr->name) == 0) {
209     break;
210     }
211     prevPtrPtr = &resPtr->nextPtr;
212     }
213    
214     /*
215     * If we found the scheme, delete it.
216     */
217     if (resPtr) {
218     /*
219     * If we're deleting a scheme with compiled variable resolution
220     * rules, bump the compiler epoch to invalidate compiled code.
221     * If we're deleting a scheme with command resolution rules,
222     * bump the cmdRefEpoch in all namespaces.
223     */
224     if (resPtr->compiledVarResProc) {
225     iPtr->compileEpoch++;
226     }
227     if (resPtr->cmdResProc) {
228     BumpCmdRefEpochs(iPtr->globalNsPtr);
229     }
230    
231     *prevPtrPtr = resPtr->nextPtr;
232     ckfree(resPtr->name);
233     ckfree((char *) resPtr);
234    
235     return 1;
236     }
237     return 0;
238     }
239    
240     /*
241     *----------------------------------------------------------------------
242     *
243     * BumpCmdRefEpochs --
244     *
245     * This procedure is used to bump the cmdRefEpoch counters in
246     * the specified namespace and all of its child namespaces.
247     * It is used whenever name resolution schemes are added/removed
248     * from an interpreter, to invalidate all command references.
249     *
250     * Results:
251     * None.
252     *
253     * Side effects:
254     * Bumps the cmdRefEpoch in the specified namespace and its
255     * children, recursively.
256     *
257     *----------------------------------------------------------------------
258     */
259    
260     static void
261     BumpCmdRefEpochs(nsPtr)
262     Namespace *nsPtr; /* Namespace being modified. */
263     {
264     Tcl_HashEntry *entry;
265     Tcl_HashSearch search;
266     Namespace *childNsPtr;
267    
268     nsPtr->cmdRefEpoch++;
269    
270     for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
271     entry != NULL;
272     entry = Tcl_NextHashEntry(&search)) {
273    
274     childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
275     BumpCmdRefEpochs(childNsPtr);
276     }
277     }
278    
279    
280     /*
281     *----------------------------------------------------------------------
282     *
283     * Tcl_SetNamespaceResolvers --
284     *
285     * Sets the command/variable resolution procedures for a namespace,
286     * thereby changing the way that command/variable names are
287     * interpreted. This allows extension writers to support different
288     * name resolution schemes, such as those for object-oriented
289     * packages.
290     *
291     * Command resolution is handled by a procedure of the following
292     * type:
293     *
294     * typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((
295     * Tcl_Interp* interp, char* name, Tcl_Namespace *context,
296     * int flags, Tcl_Command *rPtr));
297     *
298     * Whenever a command is executed or Tcl_FindCommand is invoked
299     * within the namespace, this procedure is called to resolve the
300     * command name. If this procedure is able to resolve the name,
301     * it should return the status code TCL_OK, along with the
302     * corresponding Tcl_Command in the rPtr argument. Otherwise,
303     * the procedure can return TCL_CONTINUE, and the command will
304     * be treated under the usual name resolution rules. Or, it can
305     * return TCL_ERROR, and the command will be considered invalid.
306     *
307     * Variable resolution is handled by two procedures. The first
308     * is called whenever a variable needs to be resolved at compile
309     * time:
310     *
311     * typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
312     * Tcl_Interp* interp, char* name, Tcl_Namespace *context,
313     * Tcl_ResolvedVarInfo *rPtr));
314     *
315     * If this procedure is able to resolve the name, it should return
316     * the status code TCL_OK, along with variable resolution info in
317     * the rPtr argument; this info will be used to set up compiled
318     * locals in the call frame at runtime. The procedure may also
319     * return TCL_CONTINUE, and the variable will be treated under
320     * the usual name resolution rules. Or, it can return TCL_ERROR,
321     * and the variable will be considered invalid.
322     *
323     * Another procedure is used whenever a variable needs to be
324     * resolved at runtime but it is not recognized as a compiled local.
325     * (For example, the variable may be requested via
326     * Tcl_FindNamespaceVar.) This procedure has the following type:
327     *
328     * typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
329     * Tcl_Interp* interp, char* name, Tcl_Namespace *context,
330     * int flags, Tcl_Var *rPtr));
331     *
332     * This procedure is quite similar to the compile-time version.
333     * It returns the same status codes, but if variable resolution
334     * succeeds, this procedure returns a Tcl_Var directly via the
335     * rPtr argument.
336     *
337     * Results:
338     * Nothing.
339     *
340     * Side effects:
341     * Bumps the command epoch counter for the namespace, invalidating
342     * all command references in that namespace. Also bumps the
343     * resolver epoch counter for the namespace, forcing all code
344     * in the namespace to be recompiled.
345     *
346     *----------------------------------------------------------------------
347     */
348    
349     void
350     Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
351     Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules
352     * are being modified. */
353     Tcl_ResolveCmdProc *cmdProc; /* Procedure for command resolution */
354     Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution
355     * at runtime */
356     Tcl_ResolveCompiledVarProc *compiledVarProc;
357     /* Procedure for variable resolution
358     * at compile time. */
359     {
360     Namespace *nsPtr = (Namespace*)namespacePtr;
361    
362     /*
363     * Plug in the new command resolver, and bump the epoch counters
364     * so that all code will have to be recompiled and all commands
365     * will have to be resolved again using the new policy.
366     */
367     nsPtr->cmdResProc = cmdProc;
368     nsPtr->varResProc = varProc;
369     nsPtr->compiledVarResProc = compiledVarProc;
370    
371     nsPtr->cmdRefEpoch++;
372     nsPtr->resolverEpoch++;
373     }
374    
375     /*
376     *----------------------------------------------------------------------
377     *
378     * Tcl_GetNamespaceResolvers --
379     *
380     * Returns the current command/variable resolution procedures
381     * for a namespace. By default, these procedures are NULL.
382     * New procedures can be installed by calling
383     * Tcl_SetNamespaceResolvers, to provide new name resolution
384     * rules.
385     *
386     * Results:
387     * Returns non-zero if any name resolution procedures have been
388     * assigned to this namespace; also returns pointers to the
389     * procedures in the Tcl_ResolverInfo structure. Returns zero
390     * otherwise.
391     *
392     * Side effects:
393     * None.
394     *
395     *----------------------------------------------------------------------
396     */
397    
398     int
399     Tcl_GetNamespaceResolvers(namespacePtr, resInfoPtr)
400    
401     Tcl_Namespace *namespacePtr; /* Namespace whose resolution rules
402     * are being modified. */
403     Tcl_ResolverInfo *resInfoPtr; /* Returns: pointers for all
404     * name resolution procedures
405     * assigned to this namespace. */
406     {
407     Namespace *nsPtr = (Namespace*)namespacePtr;
408    
409     resInfoPtr->cmdResProc = nsPtr->cmdResProc;
410     resInfoPtr->varResProc = nsPtr->varResProc;
411     resInfoPtr->compiledVarResProc = nsPtr->compiledVarResProc;
412    
413     if (nsPtr->cmdResProc != NULL ||
414     nsPtr->varResProc != NULL ||
415     nsPtr->compiledVarResProc != NULL) {
416     return 1;
417     }
418     return 0;
419     }
420    
421     /* End of tclresolve.c */

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25