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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 67 - (show annotations) (download)
Mon Oct 31 00:57:34 2016 UTC (7 years, 4 months ago) by dashley
File MIME type: text/plain
File size: 48569 byte(s)
Header and footer cleanup.
1 /* $Header$ */
2 /*
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 /* End of tclproc.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25