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