![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclproc.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tcl|
Return to tclproc.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 root 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
18: static 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:
27: static int InterpProc _ANSI_ARGS_((ClientData clientData,
28: Tcl_Interp *interp, int argc, char **argv));
29: static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
30:
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 */
49: int
50: Tcl_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:
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:
184: int
185: TclGetFrame(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:
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 */
265: int
266: Tcl_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:
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:
350: Proc *
351: TclFindProc(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:
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:
387: Proc *
388: TclIsProc(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:
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:
414: static int
415: InterpProc(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:
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:
552: static void
553: ProcDeleteProc(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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.