]> git.zerfleddert.de Git - micropolis/blame - src/tcl/tclproc.c
fix colors on BGR displays
[micropolis] / src / tcl / tclproc.c
CommitLineData
6a5fa4e0
MG
1/*
2 * tclProc.c --
3 *
4 * This file contains routines that implement Tcl procedures,
5 * including the "proc" and "uplevel" commands.
6 *
7 * Copyright 1987-1991 Regents of the University of California
8 * Permission to use, copy, modify, and distribute this
9 * software and its documentation for any purpose and without
10 * fee is hereby granted, provided that the above copyright
11 * notice appear in all copies. The University of California
12 * makes no representations about the suitability of this
13 * software for any purpose. It is provided "as is" without
14 * express or implied warranty.
15 */
16
17#ifndef lint
18static char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclProc.c,v 1.59 91/09/30 16:59:54 ouster Exp $ SPRITE (Berkeley)";
19#endif
20
21#include "tclint.h"
22
23/*
24 * Forward references to procedures defined later in this file:
25 */
26
27static int InterpProc _ANSI_ARGS_((ClientData clientData,
28 Tcl_Interp *interp, int argc, char **argv));
29static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
30\f
31/*
32 *----------------------------------------------------------------------
33 *
34 * Tcl_ProcCmd --
35 *
36 * This procedure is invoked to process the "proc" Tcl command.
37 * See the user documentation for details on what it does.
38 *
39 * Results:
40 * A standard Tcl result value.
41 *
42 * Side effects:
43 * A new procedure gets created.
44 *
45 *----------------------------------------------------------------------
46 */
47
48 /* ARGSUSED */
49int
50Tcl_ProcCmd(dummy, interp, argc, argv)
51 ClientData dummy; /* Not used. */
52 Tcl_Interp *interp; /* Current interpreter. */
53 int argc; /* Number of arguments. */
54 char **argv; /* Argument strings. */
55{
56 register Interp *iPtr = (Interp *) interp;
57 register Proc *procPtr;
58 int result, argCount, i;
59 char **argArray = NULL;
60 Arg *lastArgPtr;
61 register Arg *argPtr = NULL; /* Initialization not needed, but
62 * prevents compiler warning. */
63
64 if (argc != 4) {
65 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
66 " name args body\"", (char *) NULL);
67 return TCL_ERROR;
68 }
69
70 procPtr = (Proc *) ckalloc(sizeof(Proc));
71 procPtr->iPtr = iPtr;
72 procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
73 strcpy(procPtr->command, argv[3]);
74 procPtr->argPtr = NULL;
75
76 /*
77 * Break up the argument list into argument specifiers, then process
78 * each argument specifier.
79 */
80
81 result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
82 if (result != TCL_OK) {
83 goto procError;
84 }
85 lastArgPtr = NULL;
86 for (i = 0; i < argCount; i++) {
87 int fieldCount, nameLength, valueLength;
88 char **fieldValues;
89
90 /*
91 * Now divide the specifier up into name and default.
92 */
93
94 result = Tcl_SplitList(interp, argArray[i], &fieldCount,
95 &fieldValues);
96 if (result != TCL_OK) {
97 goto procError;
98 }
99 if (fieldCount > 2) {
100 ckfree((char *) fieldValues);
101 Tcl_AppendResult(interp,
102 "too many fields in argument specifier \"",
103 argArray[i], "\"", (char *) NULL);
104 result = TCL_ERROR;
105 goto procError;
106 }
107 if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
108 ckfree((char *) fieldValues);
109 Tcl_AppendResult(interp, "procedure \"", argv[1],
110 "\" has argument with no name", (char *) NULL);
111 result = TCL_ERROR;
112 goto procError;
113 }
114 nameLength = strlen(fieldValues[0]) + 1;
115 if (fieldCount == 2) {
116 valueLength = strlen(fieldValues[1]) + 1;
117 } else {
118 valueLength = 0;
119 }
120 argPtr = (Arg *) ckalloc((unsigned)
121 (sizeof(Arg) - sizeof(argPtr->name) + nameLength
122 + valueLength));
123 if (lastArgPtr == NULL) {
124 procPtr->argPtr = argPtr;
125 } else {
126 lastArgPtr->nextPtr = argPtr;
127 }
128 lastArgPtr = argPtr;
129 argPtr->nextPtr = NULL;
130 strcpy(argPtr->name, fieldValues[0]);
131 if (fieldCount == 2) {
132 argPtr->defValue = argPtr->name + nameLength;
133 strcpy(argPtr->defValue, fieldValues[1]);
134 } else {
135 argPtr->defValue = NULL;
136 }
137 ckfree((char *) fieldValues);
138 }
139
140 Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
141 ProcDeleteProc);
142 ckfree((char *) argArray);
143 return TCL_OK;
144
145 procError:
146 ckfree(procPtr->command);
147 while (procPtr->argPtr != NULL) {
148 argPtr = procPtr->argPtr;
149 procPtr->argPtr = argPtr->nextPtr;
150 ckfree((char *) argPtr);
151 }
152 ckfree((char *) procPtr);
153 if (argArray != NULL) {
154 ckfree((char *) argArray);
155 }
156 return result;
157}
158\f
159/*
160 *----------------------------------------------------------------------
161 *
162 * TclGetFrame --
163 *
164 * Given a description of a procedure frame, such as the first
165 * argument to an "uplevel" or "upvar" command, locate the
166 * call frame for the appropriate level of procedure.
167 *
168 * Results:
169 * The return value is -1 if an error occurred in finding the
170 * frame (in this case an error message is left in interp->result).
171 * 1 is returned if string was either a number or a number preceded
172 * by "#" and it specified a valid frame. 0 is returned if string
173 * isn't one of the two things above (in this case, the lookup
174 * acts as if string were "1"). The variable pointed to by
175 * framePtrPtr is filled in with the address of the desired frame
176 * (unless an error occurs, in which case it isn't modified).
177 *
178 * Side effects:
179 * None.
180 *
181 *----------------------------------------------------------------------
182 */
183
184int
185TclGetFrame(interp, string, framePtrPtr)
186 Tcl_Interp *interp; /* Interpreter in which to find frame. */
187 char *string; /* String describing frame. */
188 CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
189 * if global frame indicated). */
190{
191 register Interp *iPtr = (Interp *) interp;
192 int level, result;
193 CallFrame *framePtr;
194
195 if (iPtr->varFramePtr == NULL) {
196 iPtr->result = "already at top level";
197 return -1;
198 }
199
200 /*
201 * Parse string to figure out which level number to go to.
202 */
203
204 result = 1;
205 if (*string == '#') {
206 if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
207 return -1;
208 }
209 if (level < 0) {
210 levelError:
211 Tcl_AppendResult(interp, "bad level \"", string, "\"",
212 (char *) NULL);
213 return -1;
214 }
215 } else if (isdigit(*string)) {
216 if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
217 return -1;
218 }
219 level = iPtr->varFramePtr->level - level;
220 } else {
221 level = iPtr->varFramePtr->level - 1;
222 result = 0;
223 }
224
225 /*
226 * Figure out which frame to use, and modify the interpreter so
227 * its variables come from that frame.
228 */
229
230 if (level == 0) {
231 framePtr = NULL;
232 } else {
233 for (framePtr = iPtr->varFramePtr; framePtr != NULL;
234 framePtr = framePtr->callerVarPtr) {
235 if (framePtr->level == level) {
236 break;
237 }
238 }
239 if (framePtr == NULL) {
240 goto levelError;
241 }
242 }
243 *framePtrPtr = framePtr;
244 return result;
245}
246\f
247/*
248 *----------------------------------------------------------------------
249 *
250 * Tcl_UplevelCmd --
251 *
252 * This procedure is invoked to process the "uplevel" Tcl command.
253 * See the user documentation for details on what it does.
254 *
255 * Results:
256 * A standard Tcl result value.
257 *
258 * Side effects:
259 * See the user documentation.
260 *
261 *----------------------------------------------------------------------
262 */
263
264 /* ARGSUSED */
265int
266Tcl_UplevelCmd(dummy, interp, argc, argv)
267 ClientData dummy; /* Not used. */
268 Tcl_Interp *interp; /* Current interpreter. */
269 int argc; /* Number of arguments. */
270 char **argv; /* Argument strings. */
271{
272 register Interp *iPtr = (Interp *) interp;
273 int result;
274 CallFrame *savedVarFramePtr, *framePtr;
275
276 if (argc < 2) {
277 uplevelSyntax:
278 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
279 " ?level? command ?command ...?\"", (char *) NULL);
280 return TCL_ERROR;
281 }
282
283 /*
284 * Find the level to use for executing the command.
285 */
286
287 result = TclGetFrame(interp, argv[1], &framePtr);
288 if (result == -1) {
289 return TCL_ERROR;
290 }
291 argc -= (result+1);
292 argv += (result+1);
293
294 /*
295 * Modify the interpreter state to execute in the given frame.
296 */
297
298 savedVarFramePtr = iPtr->varFramePtr;
299 iPtr->varFramePtr = framePtr;
300
301 /*
302 * Execute the residual arguments as a command.
303 */
304
305 if (argc == 0) {
306 goto uplevelSyntax;
307 }
308 if (argc == 1) {
309 result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
310 } else {
311 char *cmd;
312
313 cmd = Tcl_Concat(argc, argv);
314 result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
315 ckfree(cmd);
316 }
317 if (result == TCL_ERROR) {
318 char msg[60];
319 sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
320 Tcl_AddErrorInfo(interp, msg);
321 }
322
323 /*
324 * Restore the variable frame, and return.
325 */
326
327 iPtr->varFramePtr = savedVarFramePtr;
328 return result;
329}
330\f
331/*
332 *----------------------------------------------------------------------
333 *
334 * TclFindProc --
335 *
336 * Given the name of a procedure, return a pointer to the
337 * record describing the procedure.
338 *
339 * Results:
340 * NULL is returned if the name doesn't correspond to any
341 * procedure. Otherwise the return value is a pointer to
342 * the procedure's record.
343 *
344 * Side effects:
345 * None.
346 *
347 *----------------------------------------------------------------------
348 */
349
350Proc *
351TclFindProc(iPtr, procName)
352 Interp *iPtr; /* Interpreter in which to look. */
353 char *procName; /* Name of desired procedure. */
354{
355 Tcl_HashEntry *hPtr;
356 Command *cmdPtr;
357
358 hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
359 if (hPtr == NULL) {
360 return NULL;
361 }
362 cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
363 if (cmdPtr->proc != InterpProc) {
364 return NULL;
365 }
366 return (Proc *) cmdPtr->clientData;
367}
368\f
369/*
370 *----------------------------------------------------------------------
371 *
372 * TclIsProc --
373 *
374 * Tells whether a command is a Tcl procedure or not.
375 *
376 * Results:
377 * If the given command is actuall a Tcl procedure, the
378 * return value is the address of the record describing
379 * the procedure. Otherwise the return value is 0.
380 *
381 * Side effects:
382 * None.
383 *
384 *----------------------------------------------------------------------
385 */
386
387Proc *
388TclIsProc(cmdPtr)
389 Command *cmdPtr; /* Command to test. */
390{
391 if (cmdPtr->proc == InterpProc) {
392 return (Proc *) cmdPtr->clientData;
393 }
394 return (Proc *) 0;
395}
396\f
397/*
398 *----------------------------------------------------------------------
399 *
400 * InterpProc --
401 *
402 * When a Tcl procedure gets invoked, this routine gets invoked
403 * to interpret the procedure.
404 *
405 * Results:
406 * A standard Tcl result value, usually TCL_OK.
407 *
408 * Side effects:
409 * Depends on the commands in the procedure.
410 *
411 *----------------------------------------------------------------------
412 */
413
414static int
415InterpProc(clientData, interp, argc, argv)
416 ClientData clientData; /* Record describing procedure to be
417 * interpreted. */
418 Tcl_Interp *interp; /* Interpreter in which procedure was
419 * invoked. */
420 int argc; /* Count of number of arguments to this
421 * procedure. */
422 char **argv; /* Argument values. */
423{
424 register Proc *procPtr = (Proc *) clientData;
425 register Arg *argPtr;
426 register Interp *iPtr = (Interp *) interp;
427 char **args;
428 CallFrame frame;
429 char *value, *end;
430 int result;
431
432 /*
433 * Set up a call frame for the new procedure invocation.
434 */
435
436 iPtr = procPtr->iPtr;
437 Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
438 if (iPtr->varFramePtr != NULL) {
439 frame.level = iPtr->varFramePtr->level + 1;
440 } else {
441 frame.level = 1;
442 }
443 frame.argc = argc;
444 frame.argv = argv;
445 frame.callerPtr = iPtr->framePtr;
446 frame.callerVarPtr = iPtr->varFramePtr;
447 iPtr->framePtr = &frame;
448 iPtr->varFramePtr = &frame;
449
450 /*
451 * Match the actual arguments against the procedure's formal
452 * parameters to compute local variables.
453 */
454
455 for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
456 argPtr != NULL;
457 argPtr = argPtr->nextPtr, args++, argc--) {
458
459 /*
460 * Handle the special case of the last formal being "args". When
461 * it occurs, assign it a list consisting of all the remaining
462 * actual arguments.
463 */
464
465 if ((argPtr->nextPtr == NULL)
466 && (strcmp(argPtr->name, "args") == 0)) {
467 if (argc < 0) {
468 argc = 0;
469 }
470 value = Tcl_Merge(argc, args);
471 Tcl_SetVar(interp, argPtr->name, value, 0);
472 ckfree(value);
473 argc = 0;
474 break;
475 } else if (argc > 0) {
476 value = *args;
477 } else if (argPtr->defValue != NULL) {
478 value = argPtr->defValue;
479 } else {
480 Tcl_AppendResult(interp, "no value given for parameter \"",
481 argPtr->name, "\" to \"", argv[0], "\"",
482 (char *) NULL);
483 result = TCL_ERROR;
484 goto procDone;
485 }
486 Tcl_SetVar(interp, argPtr->name, value, 0);
487 }
488 if (argc > 0) {
489 Tcl_AppendResult(interp, "called \"", argv[0],
490 "\" with too many arguments", (char *) NULL);
491 result = TCL_ERROR;
492 goto procDone;
493 }
494
495 /*
496 * Invoke the commands in the procedure's body.
497 */
498
499 result = Tcl_Eval(interp, procPtr->command, 0, &end);
500 if (result == TCL_RETURN) {
501 result = TCL_OK;
502 } else if (result == TCL_ERROR) {
503 char msg[100];
504
505 /*
506 * Record information telling where the error occurred.
507 */
508
509 sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0],
510 iPtr->errorLine);
511 Tcl_AddErrorInfo(interp, msg);
512 } else if (result == TCL_BREAK) {
513 iPtr->result = "invoked \"break\" outside of a loop";
514 result = TCL_ERROR;
515 } else if (result == TCL_CONTINUE) {
516 iPtr->result = "invoked \"continue\" outside of a loop";
517 result = TCL_ERROR;
518 }
519
520 /*
521 * Delete the call frame for this procedure invocation (it's
522 * important to remove the call frame from the interpreter
523 * before deleting it, so that traces invoked during the
524 * deletion don't see the partially-deleted frame).
525 */
526
527 procDone:
528 iPtr->framePtr = frame.callerPtr;
529 iPtr->varFramePtr = frame.callerVarPtr;
530 TclDeleteVars(iPtr, &frame.varTable);
531 return result;
532}
533\f
534/*
535 *----------------------------------------------------------------------
536 *
537 * ProcDeleteProc --
538 *
539 * This procedure is invoked just before a command procedure is
540 * removed from an interpreter. Its job is to release all the
541 * resources allocated to the procedure.
542 *
543 * Results:
544 * None.
545 *
546 * Side effects:
547 * Memory gets freed.
548 *
549 *----------------------------------------------------------------------
550 */
551
552static void
553ProcDeleteProc(clientData)
554 ClientData clientData; /* Procedure to be deleted. */
555{
556 register Proc *procPtr = (Proc *) clientData;
557 register Arg *argPtr;
558
559 ckfree((char *) procPtr->command);
560 for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
561 Arg *nextPtr = argPtr->nextPtr;
562
563 ckfree((char *) argPtr);
564 argPtr = nextPtr;
565 }
566 ckfree((char *) procPtr);
567}
Impressum, Datenschutz