/[dtapublic]/to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclproc.c
ViewVC logotype

Contents of /to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclproc.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25