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

Annotation of /projs/trunk/shared_source/tcl_base/tclresolve.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25