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

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclproc.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (hide annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (7 years, 8 months ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tclproc.c
File MIME type: text/plain
File size: 48894 byte(s)
Initial commit.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclproc.c,v 1.1.1.1 2001/06/13 04:45:29 dtashley Exp $ */
2    
3     /*
4     * tclProc.c --
5     *
6     * This file contains routines that implement Tcl procedures,
7     * including the "proc" and "uplevel" commands.
8     *
9     * Copyright (c) 1987-1993 The Regents of the University of California.
10     * Copyright (c) 1994-1998 Sun Microsystems, Inc.
11     *
12     * See the file "license.terms" for information on usage and redistribution
13     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14     *
15     * RCS: @(#) $Id: tclproc.c,v 1.1.1.1 2001/06/13 04:45:29 dtashley Exp $
16     */
17    
18     #include "tclInt.h"
19     #include "tclCompile.h"
20    
21     /*
22     * Prototypes for static functions in this file
23     */
24    
25     static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
26     static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
27     static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
28     Tcl_Obj *objPtr));
29     static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
30     static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
31     char *procName, int nameLen, int returnCode));
32    
33     /*
34     * The ProcBodyObjType type
35     */
36    
37     Tcl_ObjType tclProcBodyType = {
38     "procbody", /* name for this type */
39     ProcBodyFree, /* FreeInternalRep procedure */
40     ProcBodyDup, /* DupInternalRep procedure */
41     ProcBodyUpdateString, /* UpdateString procedure */
42     ProcBodySetFromAny /* SetFromAny procedure */
43     };
44    
45     /*
46     *----------------------------------------------------------------------
47     *
48     * Tcl_ProcObjCmd --
49     *
50     * This object-based procedure is invoked to process the "proc" Tcl
51     * command. See the user documentation for details on what it does.
52     *
53     * Results:
54     * A standard Tcl object result value.
55     *
56     * Side effects:
57     * A new procedure gets created.
58     *
59     *----------------------------------------------------------------------
60     */
61    
62     /* ARGSUSED */
63     int
64     Tcl_ProcObjCmd(dummy, interp, objc, objv)
65     ClientData dummy; /* Not used. */
66     Tcl_Interp *interp; /* Current interpreter. */
67     int objc; /* Number of arguments. */
68     Tcl_Obj *CONST objv[]; /* Argument objects. */
69     {
70     register Interp *iPtr = (Interp *) interp;
71     Proc *procPtr;
72     char *fullName, *procName;
73     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
74     Tcl_Command cmd;
75     Tcl_DString ds;
76    
77     if (objc != 4) {
78     Tcl_WrongNumArgs(interp, 1, objv, "name args body");
79     return TCL_ERROR;
80     }
81    
82     /*
83     * Determine the namespace where the procedure should reside. Unless
84     * the command name includes namespace qualifiers, this will be the
85     * current namespace.
86     */
87    
88     fullName = TclGetString(objv[1]);
89     TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
90     0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
91    
92     if (nsPtr == NULL) {
93     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
94     "can't create procedure \"", fullName,
95     "\": unknown namespace", (char *) NULL);
96     return TCL_ERROR;
97     }
98     if (procName == NULL) {
99     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
100     "can't create procedure \"", fullName,
101     "\": bad procedure name", (char *) NULL);
102     return TCL_ERROR;
103     }
104     if ((nsPtr != iPtr->globalNsPtr)
105     && (procName != NULL) && (procName[0] == ':')) {
106     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
107     "can't create procedure \"", procName,
108     "\" in non-global namespace with name starting with \":\"",
109     (char *) NULL);
110     return TCL_ERROR;
111     }
112    
113     /*
114     * Create the data structure to represent the procedure.
115     */
116     if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
117     &procPtr) != TCL_OK) {
118     return TCL_ERROR;
119     }
120    
121     /*
122     * Now create a command for the procedure. This will initially be in
123     * the current namespace unless the procedure's name included namespace
124     * qualifiers. To create the new command in the right namespace, we
125     * generate a fully qualified name for it.
126     */
127    
128     Tcl_DStringInit(&ds);
129     if (nsPtr != iPtr->globalNsPtr) {
130     Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
131     Tcl_DStringAppend(&ds, "::", 2);
132     }
133     Tcl_DStringAppend(&ds, procName, -1);
134    
135     Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
136     (ClientData) procPtr, TclProcDeleteProc);
137     cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
138     TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
139    
140     Tcl_DStringFree(&ds);
141     /*
142     * Now initialize the new procedure's cmdPtr field. This will be used
143     * later when the procedure is called to determine what namespace the
144     * procedure will run in. This will be different than the current
145     * namespace if the proc was renamed into a different namespace.
146     */
147    
148     procPtr->cmdPtr = (Command *) cmd;
149    
150     return TCL_OK;
151     }
152    
153     /*
154     *----------------------------------------------------------------------
155     *
156     * TclCreateProc --
157     *
158     * Creates the data associated with a Tcl procedure definition.
159     * This procedure knows how to handle two types of body objects:
160     * strings and procbody. Strings are the traditional (and common) value
161     * for bodies, procbody are values created by extensions that have
162     * loaded a previously compiled script.
163     *
164     * Results:
165     * Returns TCL_OK on success, along with a pointer to a Tcl
166     * procedure definition in procPtrPtr. This definition should
167     * be freed by calling TclCleanupProc() when it is no longer
168     * needed. Returns TCL_ERROR if anything goes wrong.
169     *
170     * Side effects:
171     * If anything goes wrong, this procedure returns an error
172     * message in the interpreter.
173     *
174     *----------------------------------------------------------------------
175     */
176     int
177     TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
178     Tcl_Interp *interp; /* interpreter containing proc */
179     Namespace *nsPtr; /* namespace containing this proc */
180     char *procName; /* unqualified name of this proc */
181     Tcl_Obj *argsPtr; /* description of arguments */
182     Tcl_Obj *bodyPtr; /* command body */
183     Proc **procPtrPtr; /* returns: pointer to proc data */
184     {
185     Interp *iPtr = (Interp*)interp;
186     char **argArray = NULL;
187    
188     register Proc *procPtr;
189     int i, length, result, numArgs;
190     char *args, *bytes, *p;
191     register CompiledLocal *localPtr = NULL;
192     Tcl_Obj *defPtr;
193     int precompiled = 0;
194    
195     if (bodyPtr->typePtr == &tclProcBodyType) {
196     /*
197     * Because the body is a TclProProcBody, the actual body is already
198     * compiled, and it is not shared with anyone else, so it's OK not to
199     * unshare it (as a matter of fact, it is bad to unshare it, because
200     * there may be no source code).
201     *
202     * We don't create and initialize a Proc structure for the procedure;
203     * rather, we use what is in the body object. Note that
204     * we initialize its cmdPtr field below after we've created the command
205     * for the procedure. We increment the ref count of the Proc struct
206     * since the command (soon to be created) will be holding a reference
207     * to it.
208     */
209    
210     procPtr = (Proc *) bodyPtr->internalRep.otherValuePtr;
211     procPtr->iPtr = iPtr;
212     procPtr->refCount++;
213     precompiled = 1;
214     } else {
215     /*
216     * If the procedure's body object is shared because its string value is
217     * identical to, e.g., the body of another procedure, we must create a
218     * private copy for this procedure to use. Such sharing of procedure
219     * bodies is rare but can cause problems. A procedure body is compiled
220     * in a context that includes the number of compiler-allocated "slots"
221     * for local variables. Each formal parameter is given a local variable
222     * slot (the "procPtr->numCompiledLocals = numArgs" assignment
223     * below). This means that the same code can not be shared by two
224     * procedures that have a different number of arguments, even if their
225     * bodies are identical. Note that we don't use Tcl_DuplicateObj since
226     * we would not want any bytecode internal representation.
227     */
228    
229     if (Tcl_IsShared(bodyPtr)) {
230     bytes = Tcl_GetStringFromObj(bodyPtr, &length);
231     bodyPtr = Tcl_NewStringObj(bytes, length);
232     }
233    
234     /*
235     * Create and initialize a Proc structure for the procedure. Note that
236     * we initialize its cmdPtr field below after we've created the command
237     * for the procedure. We increment the ref count of the procedure's
238     * body object since there will be a reference to it in the Proc
239     * structure.
240     */
241    
242     Tcl_IncrRefCount(bodyPtr);
243    
244     procPtr = (Proc *) ckalloc(sizeof(Proc));
245     procPtr->iPtr = iPtr;
246     procPtr->refCount = 1;
247     procPtr->bodyPtr = bodyPtr;
248     procPtr->numArgs = 0; /* actual argument count is set below. */
249     procPtr->numCompiledLocals = 0;
250     procPtr->firstLocalPtr = NULL;
251     procPtr->lastLocalPtr = NULL;
252     }
253    
254     /*
255     * Break up the argument list into argument specifiers, then process
256     * each argument specifier.
257     * If the body is precompiled, processing is limited to checking that
258     * the the parsed argument is consistent with the one stored in the
259     * Proc.
260     * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS.
261     */
262    
263     args = Tcl_GetStringFromObj(argsPtr, &length);
264     result = Tcl_SplitList(interp, args, &numArgs, &argArray);
265     if (result != TCL_OK) {
266     goto procError;
267     }
268    
269     if (precompiled) {
270     if (numArgs > procPtr->numArgs) {
271     char buf[64 + TCL_INTEGER_SPACE + TCL_INTEGER_SPACE];
272     sprintf(buf, "\": arg list contains %d entries, precompiled header expects %d",
273     numArgs, procPtr->numArgs);
274     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
275     "procedure \"", procName,
276     buf, (char *) NULL);
277     goto procError;
278     }
279     localPtr = procPtr->firstLocalPtr;
280     } else {
281     procPtr->numArgs = numArgs;
282     procPtr->numCompiledLocals = numArgs;
283     }
284     for (i = 0; i < numArgs; i++) {
285     int fieldCount, nameLength, valueLength;
286     char **fieldValues;
287    
288     /*
289     * Now divide the specifier up into name and default.
290     */
291    
292     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
293     &fieldValues);
294     if (result != TCL_OK) {
295     goto procError;
296     }
297     if (fieldCount > 2) {
298     ckfree((char *) fieldValues);
299     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
300     "too many fields in argument specifier \"",
301     argArray[i], "\"", (char *) NULL);
302     goto procError;
303     }
304     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
305     ckfree((char *) fieldValues);
306     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
307     "procedure \"", procName,
308     "\" has argument with no name", (char *) NULL);
309     goto procError;
310     }
311    
312     nameLength = strlen(fieldValues[0]);
313     if (fieldCount == 2) {
314     valueLength = strlen(fieldValues[1]);
315     } else {
316     valueLength = 0;
317     }
318    
319     /*
320     * Check that the formal parameter name is a scalar.
321     */
322    
323     p = fieldValues[0];
324     while (*p != '\0') {
325     if (*p == '(') {
326     char *q = p;
327     do {
328     q++;
329     } while (*q != '\0');
330     q--;
331     if (*q == ')') { /* we have an array element */
332     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
333     "procedure \"", procName,
334     "\" has formal parameter \"", fieldValues[0],
335     "\" that is an array element",
336     (char *) NULL);
337     ckfree((char *) fieldValues);
338     goto procError;
339     }
340     }
341     p++;
342     }
343    
344     if (precompiled) {
345     /*
346     * compare the parsed argument with the stored one
347     */
348    
349     if ((localPtr->nameLength != nameLength)
350     || (strcmp(localPtr->name, fieldValues[0]))
351     || (localPtr->frameIndex != i)
352     || (localPtr->flags != (VAR_SCALAR | VAR_ARGUMENT))
353     || ((localPtr->defValuePtr == NULL)
354     && (fieldCount == 2))
355     || ((localPtr->defValuePtr != NULL)
356     && (fieldCount != 2))) {
357     char buf[80 + TCL_INTEGER_SPACE];
358     sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
359     i);
360     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
361     "procedure \"", procName,
362     buf, (char *) NULL);
363     ckfree((char *) fieldValues);
364     goto procError;
365     }
366    
367     /*
368     * compare the default value if any
369     */
370    
371     if (localPtr->defValuePtr != NULL) {
372     int tmpLength;
373     char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr,
374     &tmpLength);
375     if ((valueLength != tmpLength)
376     || (strncmp(fieldValues[1], tmpPtr,
377     (size_t) tmpLength))) {
378     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
379     "procedure \"", procName,
380     "\": formal parameter \"",
381     fieldValues[0],
382     "\" has default value inconsistent with precompiled body",
383     (char *) NULL);
384     ckfree((char *) fieldValues);
385     goto procError;
386     }
387     }
388    
389     localPtr = localPtr->nextPtr;
390     } else {
391     /*
392     * Allocate an entry in the runtime procedure frame's array of
393     * local variables for the argument.
394     */
395    
396     localPtr = (CompiledLocal *) ckalloc((unsigned)
397     (sizeof(CompiledLocal) - sizeof(localPtr->name)
398     + nameLength+1));
399     if (procPtr->firstLocalPtr == NULL) {
400     procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
401     } else {
402     procPtr->lastLocalPtr->nextPtr = localPtr;
403     procPtr->lastLocalPtr = localPtr;
404     }
405     localPtr->nextPtr = NULL;
406     localPtr->nameLength = nameLength;
407     localPtr->frameIndex = i;
408     localPtr->flags = VAR_SCALAR | VAR_ARGUMENT;
409     localPtr->resolveInfo = NULL;
410    
411     if (fieldCount == 2) {
412     localPtr->defValuePtr =
413     Tcl_NewStringObj(fieldValues[1], valueLength);
414     Tcl_IncrRefCount(localPtr->defValuePtr);
415     } else {
416     localPtr->defValuePtr = NULL;
417     }
418     strcpy(localPtr->name, fieldValues[0]);
419     }
420    
421     ckfree((char *) fieldValues);
422     }
423    
424     /*
425     * Now initialize the new procedure's cmdPtr field. This will be used
426     * later when the procedure is called to determine what namespace the
427     * procedure will run in. This will be different than the current
428     * namespace if the proc was renamed into a different namespace.
429     */
430    
431     *procPtrPtr = procPtr;
432     ckfree((char *) argArray);
433     return TCL_OK;
434    
435     procError:
436     if (precompiled) {
437     procPtr->refCount--;
438     } else {
439     Tcl_DecrRefCount(bodyPtr);
440     while (procPtr->firstLocalPtr != NULL) {
441     localPtr = procPtr->firstLocalPtr;
442     procPtr->firstLocalPtr = localPtr->nextPtr;
443    
444     defPtr = localPtr->defValuePtr;
445     if (defPtr != NULL) {
446     Tcl_DecrRefCount(defPtr);
447     }
448    
449     ckfree((char *) localPtr);
450     }
451     ckfree((char *) procPtr);
452     }
453     if (argArray != NULL) {
454     ckfree((char *) argArray);
455     }
456     return TCL_ERROR;
457     }
458    
459     /*
460     *----------------------------------------------------------------------
461     *
462     * TclGetFrame --
463     *
464     * Given a description of a procedure frame, such as the first
465     * argument to an "uplevel" or "upvar" command, locate the
466     * call frame for the appropriate level of procedure.
467     *
468     * Results:
469     * The return value is -1 if an error occurred in finding the frame
470     * (in this case an error message is left in the interp's result).
471     * 1 is returned if string was either a number or a number preceded
472     * by "#" and it specified a valid frame. 0 is returned if string
473     * isn't one of the two things above (in this case, the lookup
474     * acts as if string were "1"). The variable pointed to by
475     * framePtrPtr is filled in with the address of the desired frame
476     * (unless an error occurs, in which case it isn't modified).
477     *
478     * Side effects:
479     * None.
480     *
481     *----------------------------------------------------------------------
482     */
483    
484     int
485     TclGetFrame(interp, string, framePtrPtr)
486     Tcl_Interp *interp; /* Interpreter in which to find frame. */
487     char *string; /* String describing frame. */
488     CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
489     * if global frame indicated). */
490     {
491     register Interp *iPtr = (Interp *) interp;
492     int curLevel, level, result;
493     CallFrame *framePtr;
494    
495     /*
496     * Parse string to figure out which level number to go to.
497     */
498    
499     result = 1;
500     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
501     if (*string == '#') {
502     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
503     return -1;
504     }
505     if (level < 0) {
506     levelError:
507     Tcl_AppendResult(interp, "bad level \"", string, "\"",
508     (char *) NULL);
509     return -1;
510     }
511     } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
512     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
513     return -1;
514     }
515     level = curLevel - level;
516     } else {
517     level = curLevel - 1;
518     result = 0;
519     }
520    
521     /*
522     * Figure out which frame to use, and modify the interpreter so
523     * its variables come from that frame.
524     */
525    
526     if (level == 0) {
527     framePtr = NULL;
528     } else {
529     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
530     framePtr = framePtr->callerVarPtr) {
531     if (framePtr->level == level) {
532     break;
533     }
534     }
535     if (framePtr == NULL) {
536     goto levelError;
537     }
538     }
539     *framePtrPtr = framePtr;
540     return result;
541     }
542    
543     /*
544     *----------------------------------------------------------------------
545     *
546     * Tcl_UplevelObjCmd --
547     *
548     * This object procedure is invoked to process the "uplevel" Tcl
549     * command. See the user documentation for details on what it does.
550     *
551     * Results:
552     * A standard Tcl object result value.
553     *
554     * Side effects:
555     * See the user documentation.
556     *
557     *----------------------------------------------------------------------
558     */
559    
560     /* ARGSUSED */
561     int
562     Tcl_UplevelObjCmd(dummy, interp, objc, objv)
563     ClientData dummy; /* Not used. */
564     Tcl_Interp *interp; /* Current interpreter. */
565     int objc; /* Number of arguments. */
566     Tcl_Obj *CONST objv[]; /* Argument objects. */
567     {
568     register Interp *iPtr = (Interp *) interp;
569     char *optLevel;
570     int result;
571     CallFrame *savedVarFramePtr, *framePtr;
572    
573     if (objc < 2) {
574     uplevelSyntax:
575     Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
576     return TCL_ERROR;
577     }
578    
579     /*
580     * Find the level to use for executing the command.
581     */
582    
583     optLevel = TclGetString(objv[1]);
584     result = TclGetFrame(interp, optLevel, &framePtr);
585     if (result == -1) {
586     return TCL_ERROR;
587     }
588     objc -= (result+1);
589     if (objc == 0) {
590     goto uplevelSyntax;
591     }
592     objv += (result+1);
593    
594     /*
595     * Modify the interpreter state to execute in the given frame.
596     */
597    
598     savedVarFramePtr = iPtr->varFramePtr;
599     iPtr->varFramePtr = framePtr;
600    
601     /*
602     * Execute the residual arguments as a command.
603     */
604    
605     if (objc == 1) {
606     result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
607     } else {
608     /*
609     * More than one argument: concatenate them together with spaces
610     * between, then evaluate the result. Tcl_EvalObjEx will delete
611     * the object when it decrements its refcount after eval'ing it.
612     */
613     Tcl_Obj *objPtr;
614    
615     objPtr = Tcl_ConcatObj(objc, objv);
616     result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
617     }
618     if (result == TCL_ERROR) {
619     char msg[32 + TCL_INTEGER_SPACE];
620     sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
621     Tcl_AddObjErrorInfo(interp, msg, -1);
622     }
623    
624     /*
625     * Restore the variable frame, and return.
626     */
627    
628     iPtr->varFramePtr = savedVarFramePtr;
629     return result;
630     }
631    
632     /*
633     *----------------------------------------------------------------------
634     *
635     * TclFindProc --
636     *
637     * Given the name of a procedure, return a pointer to the
638     * record describing the procedure. The procedure will be
639     * looked up using the usual rules: first in the current
640     * namespace and then in the global namespace.
641     *
642     * Results:
643     * NULL is returned if the name doesn't correspond to any
644     * procedure. Otherwise, the return value is a pointer to
645     * the procedure's record. If the name is found but refers
646     * to an imported command that points to a "real" procedure
647     * defined in another namespace, a pointer to that "real"
648     * procedure's structure is returned.
649     *
650     * Side effects:
651     * None.
652     *
653     *----------------------------------------------------------------------
654     */
655    
656     Proc *
657     TclFindProc(iPtr, procName)
658     Interp *iPtr; /* Interpreter in which to look. */
659     char *procName; /* Name of desired procedure. */
660     {
661     Tcl_Command cmd;
662     Tcl_Command origCmd;
663     Command *cmdPtr;
664    
665     cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
666     (Tcl_Namespace *) NULL, /*flags*/ 0);
667     if (cmd == (Tcl_Command) NULL) {
668     return NULL;
669     }
670     cmdPtr = (Command *) cmd;
671    
672     origCmd = TclGetOriginalCommand(cmd);
673     if (origCmd != NULL) {
674     cmdPtr = (Command *) origCmd;
675     }
676     if (cmdPtr->proc != TclProcInterpProc) {
677     return NULL;
678     }
679     return (Proc *) cmdPtr->clientData;
680     }
681    
682     /*
683     *----------------------------------------------------------------------
684     *
685     * TclIsProc --
686     *
687     * Tells whether a command is a Tcl procedure or not.
688     *
689     * Results:
690     * If the given command is actually a Tcl procedure, the
691     * return value is the address of the record describing
692     * the procedure. Otherwise the return value is 0.
693     *
694     * Side effects:
695     * None.
696     *
697     *----------------------------------------------------------------------
698     */
699    
700     Proc *
701     TclIsProc(cmdPtr)
702     Command *cmdPtr; /* Command to test. */
703     {
704     Tcl_Command origCmd;
705    
706     origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
707     if (origCmd != NULL) {
708     cmdPtr = (Command *) origCmd;
709     }
710     if (cmdPtr->proc == TclProcInterpProc) {
711     return (Proc *) cmdPtr->clientData;
712     }
713     return (Proc *) 0;
714     }
715    
716     /*
717     *----------------------------------------------------------------------
718     *
719     * TclProcInterpProc --
720     *
721     * When a Tcl procedure gets invoked with an argc/argv array of
722     * strings, this routine gets invoked to interpret the procedure.
723     *
724     * Results:
725     * A standard Tcl result value, usually TCL_OK.
726     *
727     * Side effects:
728     * Depends on the commands in the procedure.
729     *
730     *----------------------------------------------------------------------
731     */
732    
733     int
734     TclProcInterpProc(clientData, interp, argc, argv)
735     ClientData clientData; /* Record describing procedure to be
736     * interpreted. */
737     Tcl_Interp *interp; /* Interpreter in which procedure was
738     * invoked. */
739     int argc; /* Count of number of arguments to this
740     * procedure. */
741     register char **argv; /* Argument values. */
742     {
743     register Tcl_Obj *objPtr;
744     register int i;
745     int result;
746    
747     /*
748     * This procedure generates an objv array for object arguments that hold
749     * the argv strings. It starts out with stack-allocated space but uses
750     * dynamically-allocated storage if needed.
751     */
752    
753     #define NUM_ARGS 20
754     Tcl_Obj *(objStorage[NUM_ARGS]);
755     register Tcl_Obj **objv = objStorage;
756    
757     /*
758     * Create the object argument array "objv". Make sure objv is large
759     * enough to hold the objc arguments plus 1 extra for the zero
760     * end-of-objv word.
761     */
762    
763     if ((argc + 1) > NUM_ARGS) {
764     objv = (Tcl_Obj **)
765     ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
766     }
767    
768     for (i = 0; i < argc; i++) {
769     objv[i] = Tcl_NewStringObj(argv[i], -1);
770     Tcl_IncrRefCount(objv[i]);
771     }
772     objv[argc] = 0;
773    
774     /*
775     * Use TclObjInterpProc to actually interpret the procedure.
776     */
777    
778     result = TclObjInterpProc(clientData, interp, argc, objv);
779    
780     /*
781     * Move the interpreter's object result to the string result,
782     * then reset the object result.
783     */
784    
785     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
786     TCL_VOLATILE);
787    
788     /*
789     * Decrement the ref counts on the objv elements since we are done
790     * with them.
791     */
792    
793     for (i = 0; i < argc; i++) {
794     objPtr = objv[i];
795     TclDecrRefCount(objPtr);
796     }
797    
798     /*
799     * Free the objv array if malloc'ed storage was used.
800     */
801    
802     if (objv != objStorage) {
803     ckfree((char *) objv);
804     }
805     return result;
806     #undef NUM_ARGS
807     }
808    
809     /*
810     *----------------------------------------------------------------------
811     *
812     * TclObjInterpProc --
813     *
814     * When a Tcl procedure gets invoked during bytecode evaluation, this
815     * object-based routine gets invoked to interpret the procedure.
816     *
817     * Results:
818     * A standard Tcl object result value.
819     *
820     * Side effects:
821     * Depends on the commands in the procedure.
822     *
823     *----------------------------------------------------------------------
824     */
825    
826     int
827     TclObjInterpProc(clientData, interp, objc, objv)
828     ClientData clientData; /* Record describing procedure to be
829     * interpreted. */
830     register Tcl_Interp *interp; /* Interpreter in which procedure was
831     * invoked. */
832     int objc; /* Count of number of arguments to this
833     * procedure. */
834     Tcl_Obj *CONST objv[]; /* Argument value objects. */
835     {
836     Interp *iPtr = (Interp *) interp;
837     register Proc *procPtr = (Proc *) clientData;
838     Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
839     CallFrame frame;
840     register CallFrame *framePtr = &frame;
841     register Var *varPtr;
842     register CompiledLocal *localPtr;
843     char *procName;
844     int nameLen, localCt, numArgs, argCt, i, result;
845    
846     /*
847     * This procedure generates an array "compiledLocals" that holds the
848     * storage for local variables. It starts out with stack-allocated space
849     * but uses dynamically-allocated storage if needed.
850     */
851    
852     #define NUM_LOCALS 20
853     Var localStorage[NUM_LOCALS];
854     Var *compiledLocals = localStorage;
855    
856     /*
857     * Get the procedure's name.
858     */
859    
860     procName = Tcl_GetStringFromObj(objv[0], &nameLen);
861    
862     /*
863     * If necessary, compile the procedure's body. The compiler will
864     * allocate frame slots for the procedure's non-argument local
865     * variables. Note that compiling the body might increase
866     * procPtr->numCompiledLocals if new local variables are found
867     * while compiling.
868     */
869    
870     result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
871     "body of proc", procName);
872    
873     if (result != TCL_OK) {
874     return result;
875     }
876    
877     /*
878     * Create the "compiledLocals" array. Make sure it is large enough to
879     * hold all the procedure's compiled local variables, including its
880     * formal parameters.
881     */
882    
883     localCt = procPtr->numCompiledLocals;
884     if (localCt > NUM_LOCALS) {
885     compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
886     }
887    
888     /*
889     * Set up and push a new call frame for the new procedure invocation.
890     * This call frame will execute in the proc's namespace, which might
891     * be different than the current namespace. The proc's namespace is
892     * that of its command, which can change if the command is renamed
893     * from one namespace to another.
894     */
895    
896     result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
897     (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
898    
899     if (result != TCL_OK) {
900     return result;
901     }
902    
903     framePtr->objc = objc;
904     framePtr->objv = objv; /* ref counts for args are incremented below */
905    
906     /*
907     * Initialize and resolve compiled variable references.
908     */
909    
910     framePtr->procPtr = procPtr;
911     framePtr->numCompiledLocals = localCt;
912     framePtr->compiledLocals = compiledLocals;
913    
914     TclInitCompiledLocals(interp, framePtr, nsPtr);
915    
916     /*
917     * Match and assign the call's actual parameters to the procedure's
918     * formal arguments. The formal arguments are described by the first
919     * numArgs entries in both the Proc structure's local variable list and
920     * the call frame's local variable array.
921     */
922    
923     numArgs = procPtr->numArgs;
924     varPtr = framePtr->compiledLocals;
925     localPtr = procPtr->firstLocalPtr;
926     argCt = objc;
927     for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) {
928     if (!TclIsVarArgument(localPtr)) {
929     panic("TclObjInterpProc: local variable %s is not argument but should be",
930     localPtr->name);
931     return TCL_ERROR;
932     }
933     if (TclIsVarTemporary(localPtr)) {
934     panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
935     return TCL_ERROR;
936     }
937    
938     /*
939     * Handle the special case of the last formal being "args". When
940     * it occurs, assign it a list consisting of all the remaining
941     * actual arguments.
942     */
943    
944     if ((i == numArgs) && ((localPtr->name[0] == 'a')
945     && (strcmp(localPtr->name, "args") == 0))) {
946     Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
947     varPtr->value.objPtr = listPtr;
948     Tcl_IncrRefCount(listPtr); /* local var is a reference */
949     varPtr->flags &= ~VAR_UNDEFINED;
950     argCt = 0;
951     break; /* done processing args */
952     } else if (argCt > 0) {
953     Tcl_Obj *objPtr = objv[i];
954     varPtr->value.objPtr = objPtr;
955     varPtr->flags &= ~VAR_UNDEFINED;
956     Tcl_IncrRefCount(objPtr); /* since the local variable now has
957     * another reference to object. */
958     } else if (localPtr->defValuePtr != NULL) {
959     Tcl_Obj *objPtr = localPtr->defValuePtr;
960     varPtr->value.objPtr = objPtr;
961     varPtr->flags &= ~VAR_UNDEFINED;
962     Tcl_IncrRefCount(objPtr); /* since the local variable now has
963     * another reference to object. */
964     } else {
965     Tcl_ResetResult(interp);
966     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
967     "no value given for parameter \"", localPtr->name,
968     "\" to \"", Tcl_GetString(objv[0]), "\"", (char *) NULL);
969     result = TCL_ERROR;
970     goto procDone;
971     }
972     varPtr++;
973     localPtr = localPtr->nextPtr;
974     }
975     if (argCt > 0) {
976     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
977     "called \"", Tcl_GetString(objv[0]),
978     "\" with too many arguments", (char *) NULL);
979     result = TCL_ERROR;
980     goto procDone;
981     }
982    
983     /*
984     * Invoke the commands in the procedure's body.
985     */
986    
987     if (tclTraceExec >= 1) {
988     #ifdef TCL_COMPILE_DEBUG
989     fprintf(stdout, "Calling proc ");
990     for (i = 0; i < objc; i++) {
991     TclPrintObject(stdout, objv[i], 15);
992     fprintf(stdout, " ");
993     }
994     fprintf(stdout, "\n");
995     #else /* TCL_COMPILE_DEBUG */
996     fprintf(stdout, "Calling proc %.*s\n", nameLen, procName);
997     #endif /*TCL_COMPILE_DEBUG*/
998     fflush(stdout);
999     }
1000    
1001     iPtr->returnCode = TCL_OK;
1002     procPtr->refCount++;
1003     result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0);
1004     procPtr->refCount--;
1005     if (procPtr->refCount <= 0) {
1006     TclProcCleanupProc(procPtr);
1007     }
1008    
1009     if (result != TCL_OK) {
1010     result = ProcessProcResultCode(interp, procName, nameLen, result);
1011     }
1012    
1013     /*
1014     * Pop and free the call frame for this procedure invocation, then
1015     * free the compiledLocals array if malloc'ed storage was used.
1016     */
1017    
1018     procDone:
1019     Tcl_PopCallFrame(interp);
1020     if (compiledLocals != localStorage) {
1021     ckfree((char *) compiledLocals);
1022     }
1023     return result;
1024     #undef NUM_LOCALS
1025     }
1026    
1027     /*
1028     *----------------------------------------------------------------------
1029     *
1030     * TclProcCompileProc --
1031     *
1032     * Called just before a procedure is executed to compile the
1033     * body to byte codes. If the type of the body is not
1034     * "byte code" or if the compile conditions have changed
1035     * (namespace context, epoch counters, etc.) then the body
1036     * is recompiled. Otherwise, this procedure does nothing.
1037     *
1038     * Results:
1039     * None.
1040     *
1041     * Side effects:
1042     * May change the internal representation of the body object
1043     * to compiled code.
1044     *
1045     *----------------------------------------------------------------------
1046     */
1047    
1048     int
1049     TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
1050     Tcl_Interp *interp; /* Interpreter containing procedure. */
1051     Proc *procPtr; /* Data associated with procedure. */
1052     Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
1053     * but could be any code fragment compiled
1054     * in the context of this procedure.) */
1055     Namespace *nsPtr; /* Namespace containing procedure. */
1056     CONST char *description; /* string describing this body of code. */
1057     CONST char *procName; /* Name of this procedure. */
1058     {
1059     Interp *iPtr = (Interp*)interp;
1060     int result;
1061     Tcl_CallFrame frame;
1062     Proc *saveProcPtr;
1063     ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
1064    
1065     /*
1066     * If necessary, compile the procedure's body. The compiler will
1067     * allocate frame slots for the procedure's non-argument local
1068     * variables. If the ByteCode already exists, make sure it hasn't been
1069     * invalidated by someone redefining a core command (this might make the
1070     * compiled code wrong). Also, if the code was compiled in/for a
1071     * different interpreter, we recompile it. Note that compiling the body
1072     * might increase procPtr->numCompiledLocals if new local variables are
1073     * found while compiling.
1074     *
1075     * Precompiled procedure bodies, however, are immutable and therefore
1076     * they are not recompiled, even if things have changed.
1077     */
1078    
1079     if (bodyPtr->typePtr == &tclByteCodeType) {
1080     if (((Interp *) *codePtr->interpHandle != iPtr)
1081     || (codePtr->compileEpoch != iPtr->compileEpoch)
1082     || (codePtr->nsPtr != nsPtr)) {
1083     if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1084     if ((Interp *) *codePtr->interpHandle != iPtr) {
1085     Tcl_AppendResult(interp,
1086     "a precompiled script jumped interps", NULL);
1087     return TCL_ERROR;
1088     }
1089     codePtr->compileEpoch = iPtr->compileEpoch;
1090     codePtr->nsPtr = nsPtr;
1091     } else {
1092     (*tclByteCodeType.freeIntRepProc)(bodyPtr);
1093     bodyPtr->typePtr = (Tcl_ObjType *) NULL;
1094     }
1095     }
1096     }
1097     if (bodyPtr->typePtr != &tclByteCodeType) {
1098     int numChars;
1099     char *ellipsis;
1100    
1101     if (tclTraceCompile >= 1) {
1102     /*
1103     * Display a line summarizing the top level command we
1104     * are about to compile.
1105     */
1106    
1107     numChars = strlen(procName);
1108     ellipsis = "";
1109     if (numChars > 50) {
1110     numChars = 50;
1111     ellipsis = "...";
1112     }
1113     fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
1114     description, numChars, procName, ellipsis);
1115     }
1116    
1117     /*
1118     * Plug the current procPtr into the interpreter and coerce
1119     * the code body to byte codes. The interpreter needs to
1120     * know which proc it's compiling so that it can access its
1121     * list of compiled locals.
1122     *
1123     * TRICKY NOTE: Be careful to push a call frame with the
1124     * proper namespace context, so that the byte codes are
1125     * compiled in the appropriate class context.
1126     */
1127    
1128     saveProcPtr = iPtr->compiledProcPtr;
1129     iPtr->compiledProcPtr = procPtr;
1130    
1131     result = Tcl_PushCallFrame(interp, &frame,
1132     (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
1133    
1134     if (result == TCL_OK) {
1135     result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
1136     Tcl_PopCallFrame(interp);
1137     }
1138    
1139     iPtr->compiledProcPtr = saveProcPtr;
1140    
1141     if (result != TCL_OK) {
1142     if (result == TCL_ERROR) {
1143     char buf[100 + TCL_INTEGER_SPACE];
1144    
1145     numChars = strlen(procName);
1146     ellipsis = "";
1147     if (numChars > 50) {
1148     numChars = 50;
1149     ellipsis = "...";
1150     }
1151     sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
1152     description, numChars, procName, ellipsis,
1153     interp->errorLine);
1154     Tcl_AddObjErrorInfo(interp, buf, -1);
1155     }
1156     return result;
1157     }
1158     } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
1159     register CompiledLocal *localPtr;
1160    
1161     /*
1162     * The resolver epoch has changed, but we only need to invalidate
1163     * the resolver cache.
1164     */
1165    
1166     for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
1167     localPtr = localPtr->nextPtr) {
1168     localPtr->flags &= ~(VAR_RESOLVED);
1169     if (localPtr->resolveInfo) {
1170     if (localPtr->resolveInfo->deleteProc) {
1171     localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
1172     } else {
1173     ckfree((char*)localPtr->resolveInfo);
1174     }
1175     localPtr->resolveInfo = NULL;
1176     }
1177     }
1178     }
1179     return TCL_OK;
1180     }
1181    
1182     /*
1183     *----------------------------------------------------------------------
1184     *
1185     * ProcessProcResultCode --
1186     *
1187     * Procedure called by TclObjInterpProc to process a return code other
1188     * than TCL_OK returned by a Tcl procedure.
1189     *
1190     * Results:
1191     * Depending on the argument return code, the result returned is
1192     * another return code and the interpreter's result is set to a value
1193     * to supplement that return code.
1194     *
1195     * Side effects:
1196     * If the result returned is TCL_ERROR, traceback information about
1197     * the procedure just executed is appended to the interpreter's
1198     * "errorInfo" variable.
1199     *
1200     *----------------------------------------------------------------------
1201     */
1202    
1203     static int
1204     ProcessProcResultCode(interp, procName, nameLen, returnCode)
1205     Tcl_Interp *interp; /* The interpreter in which the procedure
1206     * was called and returned returnCode. */
1207     char *procName; /* Name of the procedure. Used for error
1208     * messages and trace information. */
1209     int nameLen; /* Number of bytes in procedure's name. */
1210     int returnCode; /* The unexpected result code. */
1211     {
1212     Interp *iPtr = (Interp *) interp;
1213    
1214     if (returnCode == TCL_RETURN) {
1215     returnCode = TclUpdateReturnInfo(iPtr);
1216     } else if (returnCode == TCL_ERROR) {
1217     char msg[100 + TCL_INTEGER_SPACE];
1218     char *ellipsis = "";
1219     int numChars = nameLen;
1220    
1221     if (numChars > 60) {
1222     numChars = 60;
1223     ellipsis = "...";
1224     }
1225     sprintf(msg, "\n (procedure \"%.*s%s\" line %d)",
1226     numChars, procName, ellipsis, iPtr->errorLine);
1227     Tcl_AddObjErrorInfo(interp, msg, -1);
1228     } else if (returnCode == TCL_BREAK) {
1229     Tcl_ResetResult(interp);
1230     Tcl_AppendToObj(Tcl_GetObjResult(interp),
1231     "invoked \"break\" outside of a loop", -1);
1232     returnCode = TCL_ERROR;
1233     } else if (returnCode == TCL_CONTINUE) {
1234     Tcl_ResetResult(interp);
1235     Tcl_AppendToObj(Tcl_GetObjResult(interp),
1236     "invoked \"continue\" outside of a loop", -1);
1237     returnCode = TCL_ERROR;
1238     }
1239     return returnCode;
1240     }
1241    
1242     /*
1243     *----------------------------------------------------------------------
1244     *
1245     * TclProcDeleteProc --
1246     *
1247     * This procedure is invoked just before a command procedure is
1248     * removed from an interpreter. Its job is to release all the
1249     * resources allocated to the procedure.
1250     *
1251     * Results:
1252     * None.
1253     *
1254     * Side effects:
1255     * Memory gets freed, unless the procedure is actively being
1256     * executed. In this case the cleanup is delayed until the
1257     * last call to the current procedure completes.
1258     *
1259     *----------------------------------------------------------------------
1260     */
1261    
1262     void
1263     TclProcDeleteProc(clientData)
1264     ClientData clientData; /* Procedure to be deleted. */
1265     {
1266     Proc *procPtr = (Proc *) clientData;
1267    
1268     procPtr->refCount--;
1269     if (procPtr->refCount <= 0) {
1270     TclProcCleanupProc(procPtr);
1271     }
1272     }
1273    
1274     /*
1275     *----------------------------------------------------------------------
1276     *
1277     * TclProcCleanupProc --
1278     *
1279     * This procedure does all the real work of freeing up a Proc
1280     * structure. It's called only when the structure's reference
1281     * count becomes zero.
1282     *
1283     * Results:
1284     * None.
1285     *
1286     * Side effects:
1287     * Memory gets freed.
1288     *
1289     *----------------------------------------------------------------------
1290     */
1291    
1292     void
1293     TclProcCleanupProc(procPtr)
1294     register Proc *procPtr; /* Procedure to be deleted. */
1295     {
1296     register CompiledLocal *localPtr;
1297     Tcl_Obj *bodyPtr = procPtr->bodyPtr;
1298     Tcl_Obj *defPtr;
1299     Tcl_ResolvedVarInfo *resVarInfo;
1300    
1301     if (bodyPtr != NULL) {
1302     Tcl_DecrRefCount(bodyPtr);
1303     }
1304     for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
1305     CompiledLocal *nextPtr = localPtr->nextPtr;
1306    
1307     resVarInfo = localPtr->resolveInfo;
1308     if (resVarInfo) {
1309     if (resVarInfo->deleteProc) {
1310     (*resVarInfo->deleteProc)(resVarInfo);
1311     } else {
1312     ckfree((char *) resVarInfo);
1313     }
1314     }
1315    
1316     if (localPtr->defValuePtr != NULL) {
1317     defPtr = localPtr->defValuePtr;
1318     Tcl_DecrRefCount(defPtr);
1319     }
1320     ckfree((char *) localPtr);
1321     localPtr = nextPtr;
1322     }
1323     ckfree((char *) procPtr);
1324     }
1325    
1326     /*
1327     *----------------------------------------------------------------------
1328     *
1329     * TclUpdateReturnInfo --
1330     *
1331     * This procedure is called when procedures return, and at other
1332     * points where the TCL_RETURN code is used. It examines fields
1333     * such as iPtr->returnCode and iPtr->errorCode and modifies
1334     * the real return status accordingly.
1335     *
1336     * Results:
1337     * The return value is the true completion code to use for
1338     * the procedure, instead of TCL_RETURN.
1339     *
1340     * Side effects:
1341     * The errorInfo and errorCode variables may get modified.
1342     *
1343     *----------------------------------------------------------------------
1344     */
1345    
1346     int
1347     TclUpdateReturnInfo(iPtr)
1348     Interp *iPtr; /* Interpreter for which TCL_RETURN
1349     * exception is being processed. */
1350     {
1351     int code;
1352    
1353     code = iPtr->returnCode;
1354     iPtr->returnCode = TCL_OK;
1355     if (code == TCL_ERROR) {
1356     Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
1357     (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
1358     TCL_GLOBAL_ONLY);
1359     iPtr->flags |= ERROR_CODE_SET;
1360     if (iPtr->errorInfo != NULL) {
1361     Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
1362     iPtr->errorInfo, TCL_GLOBAL_ONLY);
1363     iPtr->flags |= ERR_IN_PROGRESS;
1364     }
1365     }
1366     return code;
1367     }
1368    
1369     /*
1370     *----------------------------------------------------------------------
1371     *
1372     * TclGetInterpProc --
1373     *
1374     * Returns a pointer to the TclProcInterpProc procedure; this is different
1375     * from the value obtained from the TclProcInterpProc reference on systems
1376     * like Windows where import and export versions of a procedure exported
1377     * by a DLL exist.
1378     *
1379     * Results:
1380     * Returns the internal address of the TclProcInterpProc procedure.
1381     *
1382     * Side effects:
1383     * None.
1384     *
1385     *----------------------------------------------------------------------
1386     */
1387    
1388     TclCmdProcType
1389     TclGetInterpProc()
1390     {
1391     return (TclCmdProcType) TclProcInterpProc;
1392     }
1393    
1394     /*
1395     *----------------------------------------------------------------------
1396     *
1397     * TclGetObjInterpProc --
1398     *
1399     * Returns a pointer to the TclObjInterpProc procedure; this is different
1400     * from the value obtained from the TclObjInterpProc reference on systems
1401     * like Windows where import and export versions of a procedure exported
1402     * by a DLL exist.
1403     *
1404     * Results:
1405     * Returns the internal address of the TclObjInterpProc procedure.
1406     *
1407     * Side effects:
1408     * None.
1409     *
1410     *----------------------------------------------------------------------
1411     */
1412    
1413     TclObjCmdProcType
1414     TclGetObjInterpProc()
1415     {
1416     return (TclObjCmdProcType) TclObjInterpProc;
1417     }
1418    
1419     /*
1420     *----------------------------------------------------------------------
1421     *
1422     * TclNewProcBodyObj --
1423     *
1424     * Creates a new object, of type "procbody", whose internal
1425     * representation is the given Proc struct.
1426     * The newly created object's reference count is 0.
1427     *
1428     * Results:
1429     * Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
1430     *
1431     * Side effects:
1432     * The reference count in the ByteCode attached to the Proc is bumped up
1433     * by one, since the internal rep stores a pointer to it.
1434     *
1435     *----------------------------------------------------------------------
1436     */
1437    
1438     Tcl_Obj *
1439     TclNewProcBodyObj(procPtr)
1440     Proc *procPtr; /* the Proc struct to store as the internal
1441     * representation. */
1442     {
1443     Tcl_Obj *objPtr;
1444    
1445     if (!procPtr) {
1446     return (Tcl_Obj *) NULL;
1447     }
1448    
1449     objPtr = Tcl_NewStringObj("", 0);
1450    
1451     if (objPtr) {
1452     objPtr->typePtr = &tclProcBodyType;
1453     objPtr->internalRep.otherValuePtr = (VOID *) procPtr;
1454    
1455     procPtr->refCount++;
1456     }
1457    
1458     return objPtr;
1459     }
1460    
1461     /*
1462     *----------------------------------------------------------------------
1463     *
1464     * ProcBodyDup --
1465     *
1466     * Tcl_ObjType's Dup function for the proc body object.
1467     * Bumps the reference count on the Proc stored in the internal
1468     * representation.
1469     *
1470     * Results:
1471     * None.
1472     *
1473     * Side effects:
1474     * Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
1475     *
1476     *----------------------------------------------------------------------
1477     */
1478    
1479     static void ProcBodyDup(srcPtr, dupPtr)
1480     Tcl_Obj *srcPtr; /* object to copy */
1481     Tcl_Obj *dupPtr; /* target object for the duplication */
1482     {
1483     Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr;
1484    
1485     dupPtr->typePtr = &tclProcBodyType;
1486     dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
1487     procPtr->refCount++;
1488     }
1489    
1490     /*
1491     *----------------------------------------------------------------------
1492     *
1493     * ProcBodyFree --
1494     *
1495     * Tcl_ObjType's Free function for the proc body object.
1496     * The reference count on its Proc struct is decreased by 1; if the count
1497     * reaches 0, the proc is freed.
1498     *
1499     * Results:
1500     * None.
1501     *
1502     * Side effects:
1503     * If the reference count on the Proc struct reaches 0, the struct is freed.
1504     *
1505     *----------------------------------------------------------------------
1506     */
1507    
1508     static void
1509     ProcBodyFree(objPtr)
1510     Tcl_Obj *objPtr; /* the object to clean up */
1511     {
1512     Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
1513     procPtr->refCount--;
1514     if (procPtr->refCount <= 0) {
1515     TclProcCleanupProc(procPtr);
1516     }
1517     }
1518    
1519     /*
1520     *----------------------------------------------------------------------
1521     *
1522     * ProcBodySetFromAny --
1523     *
1524     * Tcl_ObjType's SetFromAny function for the proc body object.
1525     * Calls panic.
1526     *
1527     * Results:
1528     * Theoretically returns a TCL result code.
1529     *
1530     * Side effects:
1531     * Calls panic, since we can't set the value of the object from a string
1532     * representation (or any other internal ones).
1533     *
1534     *----------------------------------------------------------------------
1535     */
1536    
1537     static int
1538     ProcBodySetFromAny(interp, objPtr)
1539     Tcl_Interp *interp; /* current interpreter */
1540     Tcl_Obj *objPtr; /* object pointer */
1541     {
1542     panic("called ProcBodySetFromAny");
1543    
1544     /*
1545     * this to keep compilers happy.
1546     */
1547    
1548     return TCL_OK;
1549     }
1550    
1551     /*
1552     *----------------------------------------------------------------------
1553     *
1554     * ProcBodyUpdateString --
1555     *
1556     * Tcl_ObjType's UpdateString function for the proc body object.
1557     * Calls panic.
1558     *
1559     * Results:
1560     * None.
1561     *
1562     * Side effects:
1563     * Calls panic, since we this type has no string representation.
1564     *
1565     *----------------------------------------------------------------------
1566     */
1567    
1568     static void
1569     ProcBodyUpdateString(objPtr)
1570     Tcl_Obj *objPtr; /* the object to update */
1571     {
1572     panic("called ProcBodyUpdateString");
1573     }
1574    
1575    
1576     /* $History: tclproc.c $
1577     *
1578     * ***************** Version 1 *****************
1579     * User: Dtashley Date: 1/02/01 Time: 1:36a
1580     * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
1581     * Initial check-in.
1582     */
1583    
1584     /* End of TCLPROC.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25