Fork me on GitHub

source: git/external/tcl/tclProc.c@ 282f591

ImprovedOutputFile Timing dual_readout llp
Last change on this file since 282f591 was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

move branches/ModularDelphes to trunk
  • Property mode set to 100644
File size: 43.9 KB
Line 
1/*
2 * tclProc.c --
3 *
4 * This file contains routines that implement Tcl procedures,
5 * including the "proc" and "uplevel" commands.
6 *
7 * Copyright (c) 1987-1993 The Regents of the University of California.
8 * Copyright (c) 1994-1996 Sun Microsystems, Inc.
9 *
10 * See the file "license.terms" for information on usage and redistribution
11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclProc.c,v 1.1 2008-06-04 13:58:10 demin Exp $
14 */
15
16#include "tclInt.h"
17#include "tclCompile.h"
18
19/*
20 * Prototypes for static functions in this file
21 */
22
23static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr));
24static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
25static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
26 Tcl_Obj *objPtr));
27static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
28
29/*
30 * The ProcBodyObjType type
31 */
32
33Tcl_ObjType tclProcBodyType = {
34 "procbody", /* name for this type */
35 ProcBodyFree, /* FreeInternalRep procedure */
36 ProcBodyDup, /* DupInternalRep procedure */
37 ProcBodyUpdateString, /* UpdateString procedure */
38 ProcBodySetFromAny /* SetFromAny procedure */
39};
40
41
42
43/*
44 *----------------------------------------------------------------------
45 *
46 * Tcl_ProcObjCmd --
47 *
48 * This object-based procedure is invoked to process the "proc" Tcl
49 * command. See the user documentation for details on what it does.
50 *
51 * Results:
52 * A standard Tcl object result value.
53 *
54 * Side effects:
55 * A new procedure gets created.
56 *
57 *----------------------------------------------------------------------
58 */
59
60 /* ARGSUSED */
61int
62Tcl_ProcObjCmd(dummy, interp, objc, objv)
63 ClientData dummy; /* Not used. */
64 Tcl_Interp *interp; /* Current interpreter. */
65 int objc; /* Number of arguments. */
66 Tcl_Obj *CONST objv[]; /* Argument objects. */
67{
68 register Interp *iPtr = (Interp *) interp;
69 Proc *procPtr;
70 char *fullName, *procName;
71 Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
72 Tcl_Command cmd;
73 Tcl_DString ds;
74
75 if (objc != 4) {
76 Tcl_WrongNumArgs(interp, 1, objv, "name args body");
77 return TCL_ERROR;
78 }
79
80 /*
81 * Determine the namespace where the procedure should reside. Unless
82 * the command name includes namespace qualifiers, this will be the
83 * current namespace.
84 */
85
86 fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
87 TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
88 /*flags*/ 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
89
90 if (nsPtr == NULL) {
91 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
92 "can't create procedure \"", fullName,
93 "\": unknown namespace", (char *) NULL);
94 return TCL_ERROR;
95 }
96 if (procName == NULL) {
97 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
98 "can't create procedure \"", fullName,
99 "\": bad procedure name", (char *) NULL);
100 return TCL_ERROR;
101 }
102 if ((nsPtr != iPtr->globalNsPtr)
103 && (procName != NULL) && (procName[0] == ':')) {
104 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
105 "can't create procedure \"", procName,
106 "\" in non-global namespace with name starting with \":\"",
107 (char *) NULL);
108 return TCL_ERROR;
109 }
110
111 /*
112 * Create the data structure to represent the procedure.
113 */
114 if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3],
115 &procPtr) != TCL_OK) {
116 return TCL_ERROR;
117 }
118
119 /*
120 * Now create a command for the procedure. This will initially be in
121 * the current namespace unless the procedure's name included namespace
122 * qualifiers. To create the new command in the right namespace, we
123 * generate a fully qualified name for it.
124 */
125
126 Tcl_DStringInit(&ds);
127 if (nsPtr != iPtr->globalNsPtr) {
128 Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
129 Tcl_DStringAppend(&ds, "::", 2);
130 }
131 Tcl_DStringAppend(&ds, procName, -1);
132
133 Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc,
134 (ClientData) procPtr, TclProcDeleteProc);
135 cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
136 TclObjInterpProc, (ClientData) procPtr, TclProcDeleteProc);
137
138 /*
139 * Now initialize the new procedure's cmdPtr field. This will be used
140 * later when the procedure is called to determine what namespace the
141 * procedure will run in. This will be different than the current
142 * namespace if the proc was renamed into a different namespace.
143 */
144
145 procPtr->cmdPtr = (Command *) cmd;
146
147 return TCL_OK;
148}
149
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 */
175int
176TclCreateProc(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;
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[128];
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[128];
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
434procError:
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 *----------------------------------------------------------------------
462 *
463 * TclGetFrame --
464 *
465 * Given a description of a procedure frame, such as the first
466 * argument to an "uplevel" or "upvar" command, locate the
467 * call frame for the appropriate level of procedure.
468 *
469 * Results:
470 * The return value is -1 if an error occurred in finding the
471 * frame (in this case an error message is left in interp->result).
472 * 1 is returned if string was either a number or a number preceded
473 * by "#" and it specified a valid frame. 0 is returned if string
474 * isn't one of the two things above (in this case, the lookup
475 * acts as if string were "1"). The variable pointed to by
476 * framePtrPtr is filled in with the address of the desired frame
477 * (unless an error occurs, in which case it isn't modified).
478 *
479 * Side effects:
480 * None.
481 *
482 *----------------------------------------------------------------------
483 */
484
485int
486TclGetFrame(interp, string, framePtrPtr)
487 Tcl_Interp *interp; /* Interpreter in which to find frame. */
488 char *string; /* String describing frame. */
489 CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
490 * if global frame indicated). */
491{
492 register Interp *iPtr = (Interp *) interp;
493 int curLevel, level, result;
494 CallFrame *framePtr;
495
496 /*
497 * Parse string to figure out which level number to go to.
498 */
499
500 result = 1;
501 curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
502 if (*string == '#') {
503 if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
504 return -1;
505 }
506 if (level < 0) {
507 levelError:
508 Tcl_AppendResult(interp, "bad level \"", string, "\"",
509 (char *) NULL);
510 return -1;
511 }
512 } else if (isdigit(UCHAR(*string))) {
513 if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
514 return -1;
515 }
516 level = curLevel - level;
517 } else {
518 level = curLevel - 1;
519 result = 0;
520 }
521
522 /*
523 * Figure out which frame to use, and modify the interpreter so
524 * its variables come from that frame.
525 */
526
527 if (level == 0) {
528 framePtr = NULL;
529 } else {
530 for (framePtr = iPtr->varFramePtr; framePtr != NULL;
531 framePtr = framePtr->callerVarPtr) {
532 if (framePtr->level == level) {
533 break;
534 }
535 }
536 if (framePtr == NULL) {
537 goto levelError;
538 }
539 }
540 *framePtrPtr = framePtr;
541 return result;
542}
543
544
545/*
546 *----------------------------------------------------------------------
547 *
548 * Tcl_UplevelObjCmd --
549 *
550 * This object procedure is invoked to process the "uplevel" Tcl
551 * command. See the user documentation for details on what it does.
552 *
553 * Results:
554 * A standard Tcl object result value.
555 *
556 * Side effects:
557 * See the user documentation.
558 *
559 *----------------------------------------------------------------------
560 */
561
562 /* ARGSUSED */
563int
564Tcl_UplevelObjCmd(dummy, interp, objc, objv)
565 ClientData dummy; /* Not used. */
566 Tcl_Interp *interp; /* Current interpreter. */
567 int objc; /* Number of arguments. */
568 Tcl_Obj *CONST objv[]; /* Argument objects. */
569{
570 register Interp *iPtr = (Interp *) interp;
571 char *optLevel;
572 int length, result;
573 CallFrame *savedVarFramePtr, *framePtr;
574
575 if (objc < 2) {
576 uplevelSyntax:
577 Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
578 return TCL_ERROR;
579 }
580
581 /*
582 * Find the level to use for executing the command.
583 * THIS FAILS IF THE OBJECT RESULT'S STRING REP CONTAINS A NULL.
584 */
585
586 optLevel = Tcl_GetStringFromObj(objv[1], &length);
587 result = TclGetFrame(interp, optLevel, &framePtr);
588 if (result == -1) {
589 return TCL_ERROR;
590 }
591 objc -= (result+1);
592 if (objc == 0) {
593 goto uplevelSyntax;
594 }
595 objv += (result+1);
596
597 /*
598 * Modify the interpreter state to execute in the given frame.
599 */
600
601 savedVarFramePtr = iPtr->varFramePtr;
602 iPtr->varFramePtr = framePtr;
603
604 /*
605 * Execute the residual arguments as a command.
606 */
607
608 if (objc == 1) {
609 result = Tcl_EvalObj(interp, objv[0]);
610 } else {
611 Tcl_Obj *cmdObjPtr = Tcl_ConcatObj(objc, objv);
612 result = Tcl_EvalObj(interp, cmdObjPtr);
613 Tcl_DecrRefCount(cmdObjPtr); /* done with object */
614 }
615 if (result == TCL_ERROR) {
616 char msg[60];
617 sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
618 Tcl_AddObjErrorInfo(interp, msg, -1);
619 }
620
621 /*
622 * Restore the variable frame, and return.
623 */
624
625 iPtr->varFramePtr = savedVarFramePtr;
626 return result;
627}
628
629
630/*
631 *----------------------------------------------------------------------
632 *
633 * TclFindProc --
634 *
635 * Given the name of a procedure, return a pointer to the
636 * record describing the procedure.
637 *
638 * Results:
639 * NULL is returned if the name doesn't correspond to any
640 * procedure. Otherwise the return value is a pointer to
641 * the procedure's record.
642 *
643 * Side effects:
644 * None.
645 *
646 *----------------------------------------------------------------------
647 */
648
649Proc *
650TclFindProc(iPtr, procName)
651 Interp *iPtr; /* Interpreter in which to look. */
652 char *procName; /* Name of desired procedure. */
653{
654 Tcl_Command cmd;
655 Tcl_Command origCmd;
656 Command *cmdPtr;
657
658 cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName,
659 (Tcl_Namespace *) NULL, /*flags*/ 0);
660 if (cmd == (Tcl_Command) NULL) {
661 return NULL;
662 }
663 cmdPtr = (Command *) cmd;
664
665 origCmd = TclGetOriginalCommand(cmd);
666 if (origCmd != NULL) {
667 cmdPtr = (Command *) origCmd;
668 }
669 if (cmdPtr->proc != TclProcInterpProc) {
670 return NULL;
671 }
672 return (Proc *) cmdPtr->clientData;
673}
674
675
676/*
677 *----------------------------------------------------------------------
678 *
679 * TclIsProc --
680 *
681 * Tells whether a command is a Tcl procedure or not.
682 *
683 * Results:
684 * If the given command is actually a Tcl procedure, the
685 * return value is the address of the record describing
686 * the procedure. Otherwise the return value is 0.
687 *
688 * Side effects:
689 * None.
690 *
691 *----------------------------------------------------------------------
692 */
693
694Proc *
695TclIsProc(cmdPtr)
696 Command *cmdPtr; /* Command to test. */
697{
698 Tcl_Command origCmd;
699
700 origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
701 if (origCmd != NULL) {
702 cmdPtr = (Command *) origCmd;
703 }
704 if (cmdPtr->proc == TclProcInterpProc) {
705 return (Proc *) cmdPtr->clientData;
706 }
707 return (Proc *) 0;
708}
709
710
711/*
712 *----------------------------------------------------------------------
713 *
714 * TclProcInterpProc --
715 *
716 * When a Tcl procedure gets invoked with an argc/argv array of
717 * strings, this routine gets invoked to interpret the procedure.
718 *
719 * Results:
720 * A standard Tcl result value, usually TCL_OK.
721 *
722 * Side effects:
723 * Depends on the commands in the procedure.
724 *
725 *----------------------------------------------------------------------
726 */
727
728int
729TclProcInterpProc(clientData, interp, argc, argv)
730 ClientData clientData; /* Record describing procedure to be
731 * interpreted. */
732 Tcl_Interp *interp; /* Interpreter in which procedure was
733 * invoked. */
734 int argc; /* Count of number of arguments to this
735 * procedure. */
736 register char **argv; /* Argument values. */
737{
738 register Tcl_Obj *objPtr;
739 register int i;
740 int result;
741
742 /*
743 * This procedure generates an objv array for object arguments that hold
744 * the argv strings. It starts out with stack-allocated space but uses
745 * dynamically-allocated storage if needed.
746 */
747
748#define NUM_ARGS 20
749 Tcl_Obj *(objStorage[NUM_ARGS]);
750 register Tcl_Obj **objv = objStorage;
751
752 /*
753 * Create the object argument array "objv". Make sure objv is large
754 * enough to hold the objc arguments plus 1 extra for the zero
755 * end-of-objv word.
756 */
757
758 if ((argc + 1) > NUM_ARGS) {
759 objv = (Tcl_Obj **)
760 ckalloc((unsigned)(argc + 1) * sizeof(Tcl_Obj *));
761 }
762
763 for (i = 0; i < argc; i++) {
764 objv[i] = Tcl_NewStringObj(argv[i], -1);
765 Tcl_IncrRefCount(objv[i]);
766 }
767 objv[argc] = 0;
768
769 /*
770 * Use TclObjInterpProc to actually interpret the procedure.
771 */
772
773 result = TclObjInterpProc(clientData, interp, argc, objv);
774
775 /*
776 * Move the interpreter's object result to the string result,
777 * then reset the object result.
778 * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
779 */
780
781 Tcl_SetResult(interp,
782 TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
783 TCL_VOLATILE);
784
785 /*
786 * Decrement the ref counts on the objv elements since we are done
787 * with them.
788 */
789
790 for (i = 0; i < argc; i++) {
791 objPtr = objv[i];
792 TclDecrRefCount(objPtr);
793 }
794
795 /*
796 * Free the objv array if malloc'ed storage was used.
797 */
798
799 if (objv != objStorage) {
800 ckfree((char *) objv);
801 }
802 return result;
803#undef NUM_ARGS
804}
805
806
807/*
808 *----------------------------------------------------------------------
809 *
810 * TclObjInterpProc --
811 *
812 * When a Tcl procedure gets invoked during bytecode evaluation, this
813 * object-based routine gets invoked to interpret the procedure.
814 *
815 * Results:
816 * A standard Tcl object result value.
817 *
818 * Side effects:
819 * Depends on the commands in the procedure.
820 *
821 *----------------------------------------------------------------------
822 */
823
824int
825TclObjInterpProc(clientData, interp, objc, objv)
826 ClientData clientData; /* Record describing procedure to be
827 * interpreted. */
828 Tcl_Interp *interp; /* Interpreter in which procedure was
829 * invoked. */
830 int objc; /* Count of number of arguments to this
831 * procedure. */
832 Tcl_Obj *CONST objv[]; /* Argument value objects. */
833{
834 Interp *iPtr = (Interp *) interp;
835 Proc *procPtr = (Proc *) clientData;
836 Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
837 CallFrame frame;
838 register CallFrame *framePtr = &frame;
839 register CompiledLocal *localPtr;
840 char *procName, *bytes;
841 int nameLen, localCt, numArgs, argCt, length, i, result;
842 Var *varPtr;
843
844 /*
845 * This procedure generates an array "compiledLocals" that holds the
846 * storage for local variables. It starts out with stack-allocated space
847 * but uses dynamically-allocated storage if needed.
848 */
849
850#define NUM_LOCALS 20
851 Var localStorage[NUM_LOCALS];
852 Var *compiledLocals = localStorage;
853
854 /*
855 * Get the procedure's name.
856 * THIS FAILS IF THE PROC NAME'S STRING REP HAS A NULL.
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_GetStringFromObj(objv[0], (int *) NULL),
968 "\"", (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_GetStringFromObj(objv[0], (int *) NULL),
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 fprintf(stdout, "Calling proc ");
989 for (i = 0; i < objc; i++) {
990 bytes = Tcl_GetStringFromObj(objv[i], &length);
991 TclPrintSource(stdout, bytes, TclMin(length, 15));
992 fprintf(stdout, " ");
993 }
994 fprintf(stdout, "\n");
995 fflush(stdout);
996 }
997
998 iPtr->returnCode = TCL_OK;
999 procPtr->refCount++;
1000 result = Tcl_EvalObj(interp, procPtr->bodyPtr);
1001 procPtr->refCount--;
1002 if (procPtr->refCount <= 0) {
1003 TclProcCleanupProc(procPtr);
1004 }
1005
1006 if (result != TCL_OK) {
1007 if (result == TCL_RETURN) {
1008 result = TclUpdateReturnInfo(iPtr);
1009 } else if (result == TCL_ERROR) {
1010 char msg[100];
1011 sprintf(msg, "\n (procedure \"%.50s\" line %d)",
1012 procName, iPtr->errorLine);
1013 Tcl_AddObjErrorInfo(interp, msg, -1);
1014 } else if (result == TCL_BREAK) {
1015 Tcl_ResetResult(interp);
1016 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1017 "invoked \"break\" outside of a loop", -1);
1018 result = TCL_ERROR;
1019 } else if (result == TCL_CONTINUE) {
1020 Tcl_ResetResult(interp);
1021 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1022 "invoked \"continue\" outside of a loop", -1);
1023 result = TCL_ERROR;
1024 }
1025 }
1026
1027 procDone:
1028
1029 /*
1030 * Pop and free the call frame for this procedure invocation.
1031 */
1032
1033 Tcl_PopCallFrame(interp);
1034
1035 /*
1036 * Free the compiledLocals array if malloc'ed storage was used.
1037 */
1038
1039 if (compiledLocals != localStorage) {
1040 ckfree((char *) compiledLocals);
1041 }
1042 return result;
1043#undef NUM_LOCALS
1044}
1045
1046
1047/*
1048 *----------------------------------------------------------------------
1049 *
1050 * TclProcCompileProc --
1051 *
1052 * Called just before a procedure is executed to compile the
1053 * body to byte codes. If the type of the body is not
1054 * "byte code" or if the compile conditions have changed
1055 * (namespace context, epoch counters, etc.) then the body
1056 * is recompiled. Otherwise, this procedure does nothing.
1057 *
1058 * Results:
1059 * None.
1060 *
1061 * Side effects:
1062 * May change the internal representation of the body object
1063 * to compiled code.
1064 *
1065 *----------------------------------------------------------------------
1066 */
1067
1068int
1069TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
1070 Tcl_Interp *interp; /* Interpreter containing procedure. */
1071 Proc *procPtr; /* Data associated with procedure. */
1072 Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
1073 * but could be any code fragment compiled
1074 * in the context of this procedure.) */
1075 Namespace *nsPtr; /* Namespace containing procedure. */
1076 CONST char *description; /* string describing this body of code. */
1077 CONST char *procName; /* Name of this procedure. */
1078{
1079 Interp *iPtr = (Interp*)interp;
1080 int result;
1081 Tcl_CallFrame frame;
1082 Proc *saveProcPtr;
1083 ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
1084
1085 /*
1086 * If necessary, compile the procedure's body. The compiler will
1087 * allocate frame slots for the procedure's non-argument local
1088 * variables. If the ByteCode already exists, make sure it hasn't been
1089 * invalidated by someone redefining a core command (this might make the
1090 * compiled code wrong). Also, if the code was compiled in/for a
1091 * different interpreter, we recompile it. Note that compiling the body
1092 * might increase procPtr->numCompiledLocals if new local variables are
1093 * found while compiling.
1094 *
1095 * Precompiled procedure bodies, however, are immutable and therefore
1096 * they are not recompiled, even if things have changed.
1097 */
1098
1099 if (bodyPtr->typePtr == &tclByteCodeType) {
1100 if ((codePtr->iPtr != iPtr)
1101 || (codePtr->compileEpoch != iPtr->compileEpoch)
1102 || (codePtr->nsPtr != nsPtr)) {
1103 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1104 if (codePtr->iPtr != iPtr) {
1105 Tcl_AppendResult(interp,
1106 "a precompiled script jumped interps", NULL);
1107 return TCL_ERROR;
1108 }
1109 codePtr->compileEpoch = iPtr->compileEpoch;
1110 codePtr->nsPtr = nsPtr;
1111 } else {
1112 tclByteCodeType.freeIntRepProc(bodyPtr);
1113 bodyPtr->typePtr = (Tcl_ObjType *) NULL;
1114 }
1115 }
1116 }
1117 if (bodyPtr->typePtr != &tclByteCodeType) {
1118 char buf[100];
1119 int numChars;
1120 char *ellipsis;
1121
1122 if (tclTraceCompile >= 1) {
1123 /*
1124 * Display a line summarizing the top level command we
1125 * are about to compile.
1126 */
1127
1128 numChars = strlen(procName);
1129 ellipsis = "";
1130 if (numChars > 50) {
1131 numChars = 50;
1132 ellipsis = "...";
1133 }
1134 fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
1135 description, numChars, procName, ellipsis);
1136 }
1137
1138 /*
1139 * Plug the current procPtr into the interpreter and coerce
1140 * the code body to byte codes. The interpreter needs to
1141 * know which proc it's compiling so that it can access its
1142 * list of compiled locals.
1143 *
1144 * TRICKY NOTE: Be careful to push a call frame with the
1145 * proper namespace context, so that the byte codes are
1146 * compiled in the appropriate class context.
1147 */
1148
1149 saveProcPtr = iPtr->compiledProcPtr;
1150 iPtr->compiledProcPtr = procPtr;
1151
1152 result = Tcl_PushCallFrame(interp, &frame,
1153 (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
1154
1155 if (result == TCL_OK) {
1156 result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
1157 Tcl_PopCallFrame(interp);
1158 }
1159
1160 iPtr->compiledProcPtr = saveProcPtr;
1161
1162 if (result != TCL_OK) {
1163 if (result == TCL_ERROR) {
1164 numChars = strlen(procName);
1165 ellipsis = "";
1166 if (numChars > 50) {
1167 numChars = 50;
1168 ellipsis = "...";
1169 }
1170 sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
1171 description, numChars, procName, ellipsis,
1172 interp->errorLine);
1173 Tcl_AddObjErrorInfo(interp, buf, -1);
1174 }
1175 return result;
1176 }
1177 } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
1178 register CompiledLocal *localPtr;
1179
1180 /*
1181 * The resolver epoch has changed, but we only need to invalidate
1182 * the resolver cache.
1183 */
1184
1185 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
1186 localPtr = localPtr->nextPtr) {
1187 localPtr->flags &= ~(VAR_RESOLVED);
1188 if (localPtr->resolveInfo) {
1189 if (localPtr->resolveInfo->deleteProc) {
1190 localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
1191 } else {
1192 ckfree((char*)localPtr->resolveInfo);
1193 }
1194 localPtr->resolveInfo = NULL;
1195 }
1196 }
1197 }
1198 return TCL_OK;
1199}
1200
1201
1202
1203/*
1204 *----------------------------------------------------------------------
1205 *
1206 * TclProcDeleteProc --
1207 *
1208 * This procedure is invoked just before a command procedure is
1209 * removed from an interpreter. Its job is to release all the
1210 * resources allocated to the procedure.
1211 *
1212 * Results:
1213 * None.
1214 *
1215 * Side effects:
1216 * Memory gets freed, unless the procedure is actively being
1217 * executed. In this case the cleanup is delayed until the
1218 * last call to the current procedure completes.
1219 *
1220 *----------------------------------------------------------------------
1221 */
1222
1223void
1224TclProcDeleteProc(clientData)
1225 ClientData clientData; /* Procedure to be deleted. */
1226{
1227 Proc *procPtr = (Proc *) clientData;
1228
1229 procPtr->refCount--;
1230 if (procPtr->refCount <= 0) {
1231 TclProcCleanupProc(procPtr);
1232 }
1233}
1234
1235
1236/*
1237 *----------------------------------------------------------------------
1238 *
1239 * TclProcCleanupProc --
1240 *
1241 * This procedure does all the real work of freeing up a Proc
1242 * structure. It's called only when the structure's reference
1243 * count becomes zero.
1244 *
1245 * Results:
1246 * None.
1247 *
1248 * Side effects:
1249 * Memory gets freed.
1250 *
1251 *----------------------------------------------------------------------
1252 */
1253
1254void
1255TclProcCleanupProc(procPtr)
1256 register Proc *procPtr; /* Procedure to be deleted. */
1257{
1258 register CompiledLocal *localPtr;
1259 Tcl_Obj *bodyPtr = procPtr->bodyPtr;
1260 Tcl_Obj *defPtr;
1261 Tcl_ResolvedVarInfo *resVarInfo;
1262
1263 if (bodyPtr != NULL) {
1264 Tcl_DecrRefCount(bodyPtr);
1265 }
1266 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
1267 CompiledLocal *nextPtr = localPtr->nextPtr;
1268
1269 resVarInfo = localPtr->resolveInfo;
1270 if (resVarInfo) {
1271 if (resVarInfo->deleteProc) {
1272 (*resVarInfo->deleteProc)(resVarInfo);
1273 } else {
1274 ckfree((char *) resVarInfo);
1275 }
1276 }
1277
1278 if (localPtr->defValuePtr != NULL) {
1279 defPtr = localPtr->defValuePtr;
1280 Tcl_DecrRefCount(defPtr);
1281 }
1282 ckfree((char *) localPtr);
1283 localPtr = nextPtr;
1284 }
1285 ckfree((char *) procPtr);
1286}
1287
1288
1289/*
1290 *----------------------------------------------------------------------
1291 *
1292 * TclUpdateReturnInfo --
1293 *
1294 * This procedure is called when procedures return, and at other
1295 * points where the TCL_RETURN code is used. It examines fields
1296 * such as iPtr->returnCode and iPtr->errorCode and modifies
1297 * the real return status accordingly.
1298 *
1299 * Results:
1300 * The return value is the true completion code to use for
1301 * the procedure, instead of TCL_RETURN.
1302 *
1303 * Side effects:
1304 * The errorInfo and errorCode variables may get modified.
1305 *
1306 *----------------------------------------------------------------------
1307 */
1308
1309int
1310TclUpdateReturnInfo(iPtr)
1311 Interp *iPtr; /* Interpreter for which TCL_RETURN
1312 * exception is being processed. */
1313{
1314 int code;
1315
1316 code = iPtr->returnCode;
1317 iPtr->returnCode = TCL_OK;
1318 if (code == TCL_ERROR) {
1319 Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
1320 (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
1321 TCL_GLOBAL_ONLY);
1322 iPtr->flags |= ERROR_CODE_SET;
1323 if (iPtr->errorInfo != NULL) {
1324 Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
1325 iPtr->errorInfo, TCL_GLOBAL_ONLY);
1326 iPtr->flags |= ERR_IN_PROGRESS;
1327 }
1328 }
1329 return code;
1330}
1331
1332
1333/*
1334 *----------------------------------------------------------------------
1335 *
1336 * TclGetInterpProc --
1337 *
1338 * Returns a pointer to the TclProcInterpProc procedure; this is different
1339 * from the value obtained from the TclProcInterpProc reference on systems
1340 * like Windows where import and export versions of a procedure exported
1341 * by a DLL exist.
1342 *
1343 * Results:
1344 * Returns the internal address of the TclProcInterpProc procedure.
1345 *
1346 * Side effects:
1347 * None.
1348 *
1349 *----------------------------------------------------------------------
1350 */
1351
1352TclCmdProcType
1353TclGetInterpProc()
1354{
1355 return TclProcInterpProc;
1356}
1357
1358
1359/*
1360 *----------------------------------------------------------------------
1361 *
1362 * TclGetObjInterpProc --
1363 *
1364 * Returns a pointer to the TclObjInterpProc procedure; this is different
1365 * from the value obtained from the TclObjInterpProc reference on systems
1366 * like Windows where import and export versions of a procedure exported
1367 * by a DLL exist.
1368 *
1369 * Results:
1370 * Returns the internal address of the TclObjInterpProc procedure.
1371 *
1372 * Side effects:
1373 * None.
1374 *
1375 *----------------------------------------------------------------------
1376 */
1377
1378TclObjCmdProcType
1379TclGetObjInterpProc()
1380{
1381 return TclObjInterpProc;
1382}
1383
1384
1385/*
1386 *----------------------------------------------------------------------
1387 *
1388 * TclNewProcBodyObj --
1389 *
1390 * Creates a new object, of type "procbody", whose internal
1391 * representation is the given Proc struct.
1392 * The newly created object's reference count is 0.
1393 *
1394 * Results:
1395 * Returns a pointer to a newly allocated Tcl_Obj, 0 on error.
1396 *
1397 * Side effects:
1398 * The reference count in the ByteCode attached to the Proc is bumped up
1399 * by one, since the internal rep stores a pointer to it.
1400 *
1401 *----------------------------------------------------------------------
1402 */
1403
1404Tcl_Obj *
1405TclNewProcBodyObj(procPtr)
1406 Proc *procPtr; /* the Proc struct to store as the internal
1407 * representation. */
1408{
1409 Tcl_Obj *objPtr;
1410
1411 if (!procPtr) {
1412 return (Tcl_Obj *) NULL;
1413 }
1414
1415 objPtr = Tcl_NewStringObj("", 0);
1416
1417 if (objPtr) {
1418 objPtr->typePtr = &tclProcBodyType;
1419 objPtr->internalRep.otherValuePtr = (VOID *) procPtr;
1420
1421 procPtr->refCount++;
1422 }
1423
1424 return objPtr;
1425}
1426
1427
1428/*
1429 *----------------------------------------------------------------------
1430 *
1431 * ProcBodyDup --
1432 *
1433 * Tcl_ObjType's Dup function for the proc body object.
1434 * Bumps the reference count on the Proc stored in the internal
1435 * representation.
1436 *
1437 * Results:
1438 * None.
1439 *
1440 * Side effects:
1441 * Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
1442 *
1443 *----------------------------------------------------------------------
1444 */
1445
1446static void ProcBodyDup(srcPtr, dupPtr)
1447 Tcl_Obj *srcPtr; /* object to copy */
1448 Tcl_Obj *dupPtr; /* target object for the duplication */
1449{
1450 Proc *procPtr = (Proc *) srcPtr->internalRep.otherValuePtr;
1451
1452 dupPtr->typePtr = &tclProcBodyType;
1453 dupPtr->internalRep.otherValuePtr = (VOID *) procPtr;
1454 procPtr->refCount++;
1455}
1456
1457
1458/*
1459 *----------------------------------------------------------------------
1460 *
1461 * ProcBodyFree --
1462 *
1463 * Tcl_ObjType's Free function for the proc body object.
1464 * The reference count on its Proc struct is decreased by 1; if the count
1465 * reaches 0, the proc is freed.
1466 *
1467 * Results:
1468 * None.
1469 *
1470 * Side effects:
1471 * If the reference count on the Proc struct reaches 0, the struct is freed.
1472 *
1473 *----------------------------------------------------------------------
1474 */
1475
1476static void
1477ProcBodyFree(objPtr)
1478 Tcl_Obj *objPtr; /* the object to clean up */
1479{
1480 Proc *procPtr = (Proc *) objPtr->internalRep.otherValuePtr;
1481 procPtr->refCount--;
1482 if (procPtr->refCount <= 0) {
1483 TclProcCleanupProc(procPtr);
1484 }
1485}
1486
1487
1488/*
1489 *----------------------------------------------------------------------
1490 *
1491 * ProcBodySetFromAny --
1492 *
1493 * Tcl_ObjType's SetFromAny function for the proc body object.
1494 * Calls panic.
1495 *
1496 * Results:
1497 * Theoretically returns a TCL result code.
1498 *
1499 * Side effects:
1500 * Calls panic, since we can't set the value of the object from a string
1501 * representation (or any other internal ones).
1502 *
1503 *----------------------------------------------------------------------
1504 */
1505
1506static int
1507ProcBodySetFromAny(interp, objPtr)
1508 Tcl_Interp *interp; /* current interpreter */
1509 Tcl_Obj *objPtr; /* object pointer */
1510{
1511 panic("called ProcBodySetFromAny");
1512
1513 /*
1514 * this to keep compilers happy.
1515 */
1516
1517 return TCL_OK;
1518}
1519
1520
1521/*
1522 *----------------------------------------------------------------------
1523 *
1524 * ProcBodyUpdateString --
1525 *
1526 * Tcl_ObjType's UpdateString function for the proc body object.
1527 * Calls panic.
1528 *
1529 * Results:
1530 * None.
1531 *
1532 * Side effects:
1533 * Calls panic, since we this type has no string representation.
1534 *
1535 *----------------------------------------------------------------------
1536 */
1537
1538static void
1539ProcBodyUpdateString(objPtr)
1540 Tcl_Obj *objPtr; /* the object to update */
1541{
1542 panic("called ProcBodyUpdateString");
1543}
Note: See TracBrowser for help on using the repository browser.