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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25