2 * CDE - Common Desktop Environment
4 * Copyright (c) 1993-2012, The Open Group. All rights reserved.
6 * These libraries and programs are free software; you can
7 * redistribute them and/or modify them under the terms of the GNU
8 * Lesser General Public License as published by the Free Software
9 * Foundation; either version 2 of the License, or (at your option)
12 * These libraries and programs are distributed in the hope that
13 * they will be useful, but WITHOUT ANY WARRANTY; without even the
14 * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
15 * PURPOSE. See the GNU Lesser General Public License for more
18 * You should have received a copy of the GNU Lesser General Public
19 * License along with these librararies and programs; if not, write
20 * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
21 * Floor, Boston, MA 02110-1301 USA
23 /* $XConsortium: tclProc.c /main/2 1996/08/08 14:46:17 cde-hp $ */
27 * This file contains routines that implement Tcl procedures,
28 * including the "proc" and "uplevel" commands.
30 * Copyright (c) 1987-1993 The Regents of the University of California.
31 * Copyright (c) 1994-1995 Sun Microsystems, Inc.
33 * See the file "license.terms" for information on usage and redistribution
34 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
36 * SCCS: @(#) tclProc.c 1.72 96/02/15 11:42:48
42 * Forward references to procedures defined later in this file:
45 static void CleanupProc _ANSI_ARGS_((Proc *procPtr));
46 static int InterpProc _ANSI_ARGS_((ClientData clientData,
47 Tcl_Interp *interp, int argc, char **argv));
48 static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
51 *----------------------------------------------------------------------
55 * This procedure is invoked to process the "proc" Tcl command.
56 * See the user documentation for details on what it does.
59 * A standard Tcl result value.
62 * A new procedure gets created.
64 *----------------------------------------------------------------------
69 Tcl_ProcCmd(dummy, interp, argc, argv)
70 ClientData dummy; /* Not used. */
71 Tcl_Interp *interp; /* Current interpreter. */
72 int argc; /* Number of arguments. */
73 char **argv; /* Argument strings. */
75 register Interp *iPtr = (Interp *) interp;
76 register Proc *procPtr;
77 int result, argCount, i;
78 char **argArray = NULL;
80 register Arg *argPtr = NULL; /* Initialization not needed, but
81 * prevents compiler warning. */
84 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
85 " name args body\"", (char *) NULL);
89 procPtr = (Proc *) ckalloc(sizeof(Proc));
91 procPtr->refCount = 1;
92 procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
93 strcpy(procPtr->command, argv[3]);
94 procPtr->argPtr = NULL;
97 * Break up the argument list into argument specifiers, then process
98 * each argument specifier.
101 result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
102 if (result != TCL_OK) {
106 for (i = 0; i < argCount; i++) {
107 int fieldCount, nameLength, valueLength;
111 * Now divide the specifier up into name and default.
114 result = Tcl_SplitList(interp, argArray[i], &fieldCount,
116 if (result != TCL_OK) {
119 if (fieldCount > 2) {
120 ckfree((char *) fieldValues);
121 Tcl_AppendResult(interp,
122 "too many fields in argument specifier \"",
123 argArray[i], "\"", (char *) NULL);
127 if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
128 ckfree((char *) fieldValues);
129 Tcl_AppendResult(interp, "procedure \"", argv[1],
130 "\" has argument with no name", (char *) NULL);
134 nameLength = strlen(fieldValues[0]) + 1;
135 if (fieldCount == 2) {
136 valueLength = strlen(fieldValues[1]) + 1;
140 argPtr = (Arg *) ckalloc((unsigned)
141 (sizeof(Arg) - sizeof(argPtr->name) + nameLength
143 if (lastArgPtr == NULL) {
144 procPtr->argPtr = argPtr;
146 lastArgPtr->nextPtr = argPtr;
149 argPtr->nextPtr = NULL;
150 strcpy(argPtr->name, fieldValues[0]);
151 if (fieldCount == 2) {
152 argPtr->defValue = argPtr->name + nameLength;
153 strcpy(argPtr->defValue, fieldValues[1]);
155 argPtr->defValue = NULL;
157 ckfree((char *) fieldValues);
160 Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
162 ckfree((char *) argArray);
166 ckfree(procPtr->command);
167 while (procPtr->argPtr != NULL) {
168 argPtr = procPtr->argPtr;
169 procPtr->argPtr = argPtr->nextPtr;
170 ckfree((char *) argPtr);
172 ckfree((char *) procPtr);
173 if (argArray != NULL) {
174 ckfree((char *) argArray);
180 *----------------------------------------------------------------------
184 * Given a description of a procedure frame, such as the first
185 * argument to an "uplevel" or "upvar" command, locate the
186 * call frame for the appropriate level of procedure.
189 * The return value is -1 if an error occurred in finding the
190 * frame (in this case an error message is left in interp->result).
191 * 1 is returned if string was either a number or a number preceded
192 * by "#" and it specified a valid frame. 0 is returned if string
193 * isn't one of the two things above (in this case, the lookup
194 * acts as if string were "1"). The variable pointed to by
195 * framePtrPtr is filled in with the address of the desired frame
196 * (unless an error occurs, in which case it isn't modified).
201 *----------------------------------------------------------------------
205 TclGetFrame(interp, string, framePtrPtr)
206 Tcl_Interp *interp; /* Interpreter in which to find frame. */
207 char *string; /* String describing frame. */
208 CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
209 * if global frame indicated). */
211 register Interp *iPtr = (Interp *) interp;
212 int curLevel, level, result;
216 * Parse string to figure out which level number to go to.
220 curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
221 if (*string == '#') {
222 if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
227 Tcl_AppendResult(interp, "bad level \"", string, "\"",
231 } else if (isdigit(UCHAR(*string))) {
232 if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
235 level = curLevel - level;
237 level = curLevel - 1;
242 * Figure out which frame to use, and modify the interpreter so
243 * its variables come from that frame.
249 for (framePtr = iPtr->varFramePtr; framePtr != NULL;
250 framePtr = framePtr->callerVarPtr) {
251 if (framePtr->level == level) {
255 if (framePtr == NULL) {
259 *framePtrPtr = framePtr;
264 *----------------------------------------------------------------------
268 * This procedure is invoked to process the "uplevel" Tcl command.
269 * See the user documentation for details on what it does.
272 * A standard Tcl result value.
275 * See the user documentation.
277 *----------------------------------------------------------------------
282 Tcl_UplevelCmd(dummy, interp, argc, argv)
283 ClientData dummy; /* Not used. */
284 Tcl_Interp *interp; /* Current interpreter. */
285 int argc; /* Number of arguments. */
286 char **argv; /* Argument strings. */
288 register Interp *iPtr = (Interp *) interp;
290 CallFrame *savedVarFramePtr, *framePtr;
294 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
295 " ?level? command ?arg ...?\"", (char *) NULL);
300 * Find the level to use for executing the command.
303 result = TclGetFrame(interp, argv[1], &framePtr);
314 * Modify the interpreter state to execute in the given frame.
317 savedVarFramePtr = iPtr->varFramePtr;
318 iPtr->varFramePtr = framePtr;
321 * Execute the residual arguments as a command.
325 result = Tcl_Eval(interp, argv[0]);
329 cmd = Tcl_Concat(argc, argv);
330 result = Tcl_Eval(interp, cmd);
333 if (result == TCL_ERROR) {
335 sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
336 Tcl_AddErrorInfo(interp, msg);
340 * Restore the variable frame, and return.
343 iPtr->varFramePtr = savedVarFramePtr;
348 *----------------------------------------------------------------------
352 * Given the name of a procedure, return a pointer to the
353 * record describing the procedure.
356 * NULL is returned if the name doesn't correspond to any
357 * procedure. Otherwise the return value is a pointer to
358 * the procedure's record.
363 *----------------------------------------------------------------------
367 TclFindProc(iPtr, procName)
368 Interp *iPtr; /* Interpreter in which to look. */
369 char *procName; /* Name of desired procedure. */
374 hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
378 cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
379 if (cmdPtr->proc != InterpProc) {
382 return (Proc *) cmdPtr->clientData;
386 *----------------------------------------------------------------------
390 * Tells whether a command is a Tcl procedure or not.
393 * If the given command is actuall a Tcl procedure, the
394 * return value is the address of the record describing
395 * the procedure. Otherwise the return value is 0.
400 *----------------------------------------------------------------------
405 Command *cmdPtr; /* Command to test. */
407 if (cmdPtr->proc == InterpProc) {
408 return (Proc *) cmdPtr->clientData;
414 *----------------------------------------------------------------------
418 * When a Tcl procedure gets invoked, this routine gets invoked
419 * to interpret the procedure.
422 * A standard Tcl result value, usually TCL_OK.
425 * Depends on the commands in the procedure.
427 *----------------------------------------------------------------------
431 InterpProc(clientData, interp, argc, argv)
432 ClientData clientData; /* Record describing procedure to be
434 Tcl_Interp *interp; /* Interpreter in which procedure was
436 int argc; /* Count of number of arguments to this
438 char **argv; /* Argument values. */
440 register Proc *procPtr = (Proc *) clientData;
441 register Arg *argPtr;
442 register Interp *iPtr;
449 * Set up a call frame for the new procedure invocation.
452 iPtr = procPtr->iPtr;
453 Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
454 if (iPtr->varFramePtr != NULL) {
455 frame.level = iPtr->varFramePtr->level + 1;
461 frame.callerPtr = iPtr->framePtr;
462 frame.callerVarPtr = iPtr->varFramePtr;
463 iPtr->framePtr = &frame;
464 iPtr->varFramePtr = &frame;
465 iPtr->returnCode = TCL_OK;
468 * Match the actual arguments against the procedure's formal
469 * parameters to compute local variables.
472 for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
474 argPtr = argPtr->nextPtr, args++, argc--) {
477 * Handle the special case of the last formal being "args". When
478 * it occurs, assign it a list consisting of all the remaining
482 if ((argPtr->nextPtr == NULL)
483 && (strcmp(argPtr->name, "args") == 0)) {
487 value = Tcl_Merge(argc, args);
488 Tcl_SetVar(interp, argPtr->name, value, 0);
492 } else if (argc > 0) {
494 } else if (argPtr->defValue != NULL) {
495 value = argPtr->defValue;
497 Tcl_AppendResult(interp, "no value given for parameter \"",
498 argPtr->name, "\" to \"", argv[0], "\"",
503 Tcl_SetVar(interp, argPtr->name, value, 0);
506 Tcl_AppendResult(interp, "called \"", argv[0],
507 "\" with too many arguments", (char *) NULL);
513 * Invoke the commands in the procedure's body.
517 result = Tcl_Eval(interp, procPtr->command);
519 if (procPtr->refCount <= 0) {
520 CleanupProc(procPtr);
522 if (result == TCL_RETURN) {
523 result = TclUpdateReturnInfo(iPtr);
524 } else if (result == TCL_ERROR) {
528 * Record information telling where the error occurred.
531 sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0],
533 Tcl_AddErrorInfo(interp, msg);
534 } else if (result == TCL_BREAK) {
535 iPtr->result = "invoked \"break\" outside of a loop";
537 } else if (result == TCL_CONTINUE) {
538 iPtr->result = "invoked \"continue\" outside of a loop";
543 * Delete the call frame for this procedure invocation (it's
544 * important to remove the call frame from the interpreter
545 * before deleting it, so that traces invoked during the
546 * deletion don't see the partially-deleted frame).
550 iPtr->framePtr = frame.callerPtr;
551 iPtr->varFramePtr = frame.callerVarPtr;
554 * The check below is a hack. The problem is that there could be
555 * unset traces on the variables, which cause scripts to be evaluated.
556 * This will clear the ERR_IN_PROGRESS flag, losing stack trace
557 * information if the procedure was exiting with an error. The
558 * code below preserves the flag. Unfortunately, that isn't
559 * really enough: we really should preserve the errorInfo variable
560 * too (otherwise a nested error in the trace script will trash
561 * errorInfo). What's really needed is a general-purpose
562 * mechanism for saving and restoring interpreter state.
565 if (iPtr->flags & ERR_IN_PROGRESS) {
566 TclDeleteVars(iPtr, &frame.varTable);
567 iPtr->flags |= ERR_IN_PROGRESS;
569 TclDeleteVars(iPtr, &frame.varTable);
575 *----------------------------------------------------------------------
579 * This procedure is invoked just before a command procedure is
580 * removed from an interpreter. Its job is to release all the
581 * resources allocated to the procedure.
587 * Memory gets freed, unless the procedure is actively being
588 * executed. In this case the cleanup is delayed until the
589 * last call to the current procedure completes.
591 *----------------------------------------------------------------------
595 ProcDeleteProc(clientData)
596 ClientData clientData; /* Procedure to be deleted. */
598 Proc *procPtr = (Proc *) clientData;
601 if (procPtr->refCount <= 0) {
602 CleanupProc(procPtr);
607 *----------------------------------------------------------------------
611 * This procedure does all the real work of freeing up a Proc
612 * structure. It's called only when the structure's reference
613 * count becomes zero.
621 *----------------------------------------------------------------------
626 register Proc *procPtr; /* Procedure to be deleted. */
628 register Arg *argPtr;
630 ckfree((char *) procPtr->command);
631 for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
632 Arg *nextPtr = argPtr->nextPtr;
634 ckfree((char *) argPtr);
637 ckfree((char *) procPtr);
641 *----------------------------------------------------------------------
643 * TclUpdateReturnInfo --
645 * This procedure is called when procedures return, and at other
646 * points where the TCL_RETURN code is used. It examines fields
647 * such as iPtr->returnCode and iPtr->errorCode and modifies
648 * the real return status accordingly.
651 * The return value is the true completion code to use for
652 * the procedure, instead of TCL_RETURN.
655 * The errorInfo and errorCode variables may get modified.
657 *----------------------------------------------------------------------
661 TclUpdateReturnInfo(iPtr)
662 Interp *iPtr; /* Interpreter for which TCL_RETURN
663 * exception is being processed. */
667 code = iPtr->returnCode;
668 iPtr->returnCode = TCL_OK;
669 if (code == TCL_ERROR) {
670 Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
671 (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
673 iPtr->flags |= ERROR_CODE_SET;
674 if (iPtr->errorInfo != NULL) {
675 Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
676 iPtr->errorInfo, TCL_GLOBAL_ONLY);
677 iPtr->flags |= ERR_IN_PROGRESS;