1 /*
2 * tclProc.c --
3 *
4 * This file contains routines that implement Tcl procedures, including
5 * the "proc" and "uplevel" commands.
6 *
7 * Copyright © 1987-1993 The Regents of the University of California.
8 * Copyright © 1994-1998 Sun Microsystems, Inc.
9 * Copyright © 2004-2006 Miguel Sofer
10 * Copyright © 2007 Daniel A. Steffen <das@users.sourceforge.net>
11 *
12 * See the file "license.terms" for information on usage and redistribution of
13 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
14 */
15
16 #include "tclInt.h"
17 #include "tclCompile.h"
18 #include <assert.h>
19
20 /*
21 * Variables that are part of the [apply] command implementation and which
22 * have to be passed to the other side of the NRE call.
23 */
24
25 typedef struct {
26 Command cmd;
27 ExtraFrameInfo efi;
28 } ApplyExtraData;
29
30 /*
31 * Prototypes for static functions in this file
32 */
33
34 static void DupLambdaInternalRep(Tcl_Obj *objPtr,
35 Tcl_Obj *copyPtr);
36 static void FreeLambdaInternalRep(Tcl_Obj *objPtr);
37 static int InitArgsAndLocals(Tcl_Interp *interp, int skip);
38 static void InitResolvedLocals(Tcl_Interp *interp,
39 ByteCode *codePtr, Var *defPtr,
40 Namespace *nsPtr);
41 static void InitLocalCache(Proc *procPtr);
42 static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
43 static void ProcBodyFree(Tcl_Obj *objPtr);
44 static int ProcWrongNumArgs(Tcl_Interp *interp, int skip);
45 static void MakeProcError(Tcl_Interp *interp,
46 Tcl_Obj *procNameObj);
47 static void MakeLambdaError(Tcl_Interp *interp,
48 Tcl_Obj *procNameObj);
49 static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
50
51 static Tcl_NRPostProc ApplyNR2;
52 static Tcl_NRPostProc InterpProcNR2;
53 static Tcl_NRPostProc Uplevel_Callback;
54
55 /*
56 * The ProcBodyObjType type
57 */
58
59 const Tcl_ObjType tclProcBodyType = {
60 "procbody", /* name for this type */
61 ProcBodyFree, /* FreeInternalRep function */
62 ProcBodyDup, /* DupInternalRep function */
63 NULL, /* UpdateString function; Tcl_GetString and
64 * Tcl_GetStringFromObj should panic
65 * instead. */
66 NULL /* SetFromAny function; Tcl_ConvertToType
67 * should panic instead. */
68 };
69
70 #define ProcSetIntRep(objPtr, procPtr) \
71 do { \
72 Tcl_ObjIntRep ir; \
73 (procPtr)->refCount++; \
74 ir.twoPtrValue.ptr1 = (procPtr); \
75 ir.twoPtrValue.ptr2 = NULL; \
76 Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \
77 } while (0)
78
79 #define ProcGetIntRep(objPtr, procPtr) \
80 do { \
81 const Tcl_ObjIntRep *irPtr; \
82 irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \
83 (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
84 } while (0)
85
86 /*
87 * The [upvar]/[uplevel] level reference type. Uses the longValue field
88 * to remember the integer value of a parsed #<integer> format.
89 *
90 * Uses the default behaviour throughout, and never disposes of the string
91 * rep; it's just a cache type.
92 */
93
94 static const Tcl_ObjType levelReferenceType = {
95 "levelReference",
96 NULL, NULL, NULL, NULL
97 };
98
99 /*
100 * The type of lambdas. Note that every lambda will *always* have a string
101 * representation.
102 *
103 * Internally, ptr1 is a pointer to a Proc instance that is not bound to a
104 * command name, and ptr2 is a pointer to the namespace that the Proc instance
105 * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO.
106 */
107
108 static const Tcl_ObjType lambdaType = {
109 "lambdaExpr", /* name */
110 FreeLambdaInternalRep, /* freeIntRepProc */
111 DupLambdaInternalRep, /* dupIntRepProc */
112 NULL, /* updateStringProc */
113 SetLambdaFromAny /* setFromAnyProc */
114 };
115
116 #define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \
117 do { \
118 Tcl_ObjIntRep ir; \
119 ir.twoPtrValue.ptr1 = (procPtr); \
120 ir.twoPtrValue.ptr2 = (nsObjPtr); \
121 Tcl_IncrRefCount((nsObjPtr)); \
122 Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \
123 } while (0)
124
125 #define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
126 do { \
127 const Tcl_ObjIntRep *irPtr; \
128 irPtr = TclFetchIntRep((objPtr), &lambdaType); \
129 (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
130 (nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
131 } while (0)
132
133
134 /*
135 *----------------------------------------------------------------------
136 *
137 * Tcl_ProcObjCmd --
138 *
139 * This object-based function is invoked to process the "proc" Tcl
140 * command. See the user documentation for details on what it does.
141 *
142 * Results:
143 * A standard Tcl object result value.
144 *
145 * Side effects:
146 * A new procedure gets created.
147 *
148 *----------------------------------------------------------------------
149 */
150
151 int
Tcl_ProcObjCmd(TCL_UNUSED (ClientData),Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])152 Tcl_ProcObjCmd(
153 TCL_UNUSED(ClientData),
154 Tcl_Interp *interp, /* Current interpreter. */
155 int objc, /* Number of arguments. */
156 Tcl_Obj *const objv[]) /* Argument objects. */
157 {
158 Interp *iPtr = (Interp *) interp;
159 Proc *procPtr;
160 const char *procName;
161 const char *simpleName, *procArgs, *procBody;
162 Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
163 Tcl_Command cmd;
164
165 if (objc != 4) {
166 Tcl_WrongNumArgs(interp, 1, objv, "name args body");
167 return TCL_ERROR;
168 }
169
170 /*
171 * Determine the namespace where the procedure should reside. Unless the
172 * command name includes namespace qualifiers, this will be the current
173 * namespace.
174 */
175
176 procName = TclGetString(objv[1]);
177 TclGetNamespaceForQualName(interp, procName, NULL, 0,
178 &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName);
179
180 if (nsPtr == NULL) {
181 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
182 "can't create procedure \"%s\": unknown namespace",
183 procName));
184 Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
185 return TCL_ERROR;
186 }
187 if (simpleName == NULL) {
188 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
189 "can't create procedure \"%s\": bad procedure name",
190 procName));
191 Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
192 return TCL_ERROR;
193 }
194
195 /*
196 * Create the data structure to represent the procedure.
197 */
198
199 if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2],
200 objv[3], &procPtr) != TCL_OK) {
201 Tcl_AddErrorInfo(interp, "\n (creating proc \"");
202 Tcl_AddErrorInfo(interp, simpleName);
203 Tcl_AddErrorInfo(interp, "\")");
204 return TCL_ERROR;
205 }
206
207 cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
208 TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc);
209
210 /*
211 * Now initialize the new procedure's cmdPtr field. This will be used
212 * later when the procedure is called to determine what namespace the
213 * procedure will run in. This will be different than the current
214 * namespace if the proc was renamed into a different namespace.
215 */
216
217 procPtr->cmdPtr = (Command *) cmd;
218
219 /*
220 * TIP #280: Remember the line the procedure body is starting on. In a
221 * bytecode context we ask the engine to provide us with the necessary
222 * information. This is for the initialization of the byte code compiler
223 * when the body is used for the first time.
224 *
225 * This code is nearly identical to the #280 code in SetLambdaFromAny, see
226 * this file. The differences are the different index of the body in the
227 * line array of the context, and the lambda code requires some special
228 * processing. Find a way to factor the common elements into a single
229 * function.
230 */
231
232 if (iPtr->cmdFramePtr) {
233 CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
234
235 *contextPtr = *iPtr->cmdFramePtr;
236 if (contextPtr->type == TCL_LOCATION_BC) {
237 /*
238 * Retrieve source information from the bytecode, if possible. If
239 * the information is retrieved successfully, context.type will be
240 * TCL_LOCATION_SOURCE and the reference held by
241 * context.data.eval.path will be counted.
242 */
243
244 TclGetSrcInfoForPc(contextPtr);
245 } else if (contextPtr->type == TCL_LOCATION_SOURCE) {
246 /*
247 * The copy into 'context' up above has created another reference
248 * to 'context.data.eval.path'; account for it.
249 */
250
251 Tcl_IncrRefCount(contextPtr->data.eval.path);
252 }
253
254 if (contextPtr->type == TCL_LOCATION_SOURCE) {
255 /*
256 * We can account for source location within a proc only if the
257 * proc body was not created by substitution.
258 */
259
260 if (contextPtr->line
261 && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
262 int isNew;
263 Tcl_HashEntry *hePtr;
264 CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
265
266 cfPtr->level = -1;
267 cfPtr->type = contextPtr->type;
268 cfPtr->line = (int *)ckalloc(sizeof(int));
269 cfPtr->line[0] = contextPtr->line[3];
270 cfPtr->nline = 1;
271 cfPtr->framePtr = NULL;
272 cfPtr->nextPtr = NULL;
273
274 cfPtr->data.eval.path = contextPtr->data.eval.path;
275 Tcl_IncrRefCount(cfPtr->data.eval.path);
276
277 cfPtr->cmd = NULL;
278 cfPtr->len = 0;
279
280 hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
281 procPtr, &isNew);
282 if (!isNew) {
283 /*
284 * Get the old command frame and release it. See also
285 * TclProcCleanupProc in this file. Currently it seems as
286 * if only the procbodytest::proc command of the testsuite
287 * is able to trigger this situation.
288 */
289
290 CmdFrame *cfOldPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
291
292 if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
293 Tcl_DecrRefCount(cfOldPtr->data.eval.path);
294 cfOldPtr->data.eval.path = NULL;
295 }
296 ckfree(cfOldPtr->line);
297 cfOldPtr->line = NULL;
298 ckfree(cfOldPtr);
299 }
300 Tcl_SetHashValue(hePtr, cfPtr);
301 }
302
303 /*
304 * 'contextPtr' is going out of scope; account for the reference
305 * that it's holding to the path name.
306 */
307
308 Tcl_DecrRefCount(contextPtr->data.eval.path);
309 contextPtr->data.eval.path = NULL;
310 }
311 TclStackFree(interp, contextPtr);
312 }
313
314 /*
315 * Optimize for no-op procs: if the body is not precompiled (like a TclPro
316 * procbody), and the argument list is just "args" and the body is empty,
317 * define a compileProc to compile a no-op.
318 *
319 * Notes:
320 * - cannot be done for any argument list without having different
321 * compiled/not-compiled behaviour in the "wrong argument #" case, or
322 * making this code much more complicated. In any case, it doesn't
323 * seem to make a lot of sense to verify the number of arguments we
324 * are about to ignore ...
325 * - could be enhanced to handle also non-empty bodies that contain only
326 * comments; however, parsing the body will slow down the compilation
327 * of all procs whose argument list is just _args_
328 */
329
330 if (TclHasIntRep(objv[3], &tclProcBodyType)) {
331 goto done;
332 }
333
334 procArgs = TclGetString(objv[2]);
335
336 while (*procArgs == ' ') {
337 procArgs++;
338 }
339
340 if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
341 int numBytes;
342
343 procArgs +=4;
344 while (*procArgs != '\0') {
345 if (*procArgs != ' ') {
346 goto done;
347 }
348 procArgs++;
349 }
350
351 /*
352 * The argument list is just "args"; check the body
353 */
354
355 procBody = TclGetStringFromObj(objv[3], &numBytes);
356 if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) {
357 goto done;
358 }
359
360 /*
361 * The body is just spaces: link the compileProc
362 */
363
364 ((Command *) cmd)->compileProc = TclCompileNoOp;
365 }
366
367 done:
368 return TCL_OK;
369 }
370
371 /*
372 *----------------------------------------------------------------------
373 *
374 * TclCreateProc --
375 *
376 * Creates the data associated with a Tcl procedure definition. This
377 * function knows how to handle two types of body objects: strings and
378 * procbody. Strings are the traditional (and common) value for bodies,
379 * procbody are values created by extensions that have loaded a
380 * previously compiled script.
381 *
382 * Results:
383 * Returns TCL_OK on success, along with a pointer to a Tcl procedure
384 * definition in procPtrPtr where the cmdPtr field is not initialised.
385 * This definition should be freed by calling TclProcCleanupProc() when
386 * it is no longer needed. Returns TCL_ERROR if anything goes wrong.
387 *
388 * Side effects:
389 * If anything goes wrong, this function returns an error message in the
390 * interpreter.
391 *
392 *----------------------------------------------------------------------
393 */
394
395 int
TclCreateProc(Tcl_Interp * interp,TCL_UNUSED (Namespace *),const char * procName,Tcl_Obj * argsPtr,Tcl_Obj * bodyPtr,Proc ** procPtrPtr)396 TclCreateProc(
397 Tcl_Interp *interp, /* Interpreter containing proc. */
398 TCL_UNUSED(Namespace *) /*nsPtr*/,
399 const char *procName, /* Unqualified name of this proc. */
400 Tcl_Obj *argsPtr, /* Description of arguments. */
401 Tcl_Obj *bodyPtr, /* Command body. */
402 Proc **procPtrPtr) /* Returns: pointer to proc data. */
403 {
404 Interp *iPtr = (Interp *) interp;
405
406 Proc *procPtr = NULL;
407 int i, result, numArgs;
408 CompiledLocal *localPtr = NULL;
409 Tcl_Obj **argArray;
410 int precompiled = 0;
411
412 ProcGetIntRep(bodyPtr, procPtr);
413 if (procPtr != NULL) {
414 /*
415 * Because the body is a TclProProcBody, the actual body is already
416 * compiled, and it is not shared with anyone else, so it's OK not to
417 * unshare it (as a matter of fact, it is bad to unshare it, because
418 * there may be no source code).
419 *
420 * We don't create and initialize a Proc structure for the procedure;
421 * rather, we use what is in the body object. We increment the ref
422 * count of the Proc struct since the command (soon to be created)
423 * will be holding a reference to it.
424 */
425
426 procPtr->iPtr = iPtr;
427 procPtr->refCount++;
428 precompiled = 1;
429 } else {
430 /*
431 * If the procedure's body object is shared because its string value
432 * is identical to, e.g., the body of another procedure, we must
433 * create a private copy for this procedure to use. Such sharing of
434 * procedure bodies is rare but can cause problems. A procedure body
435 * is compiled in a context that includes the number of "slots"
436 * allocated by the compiler for local variables. There is a local
437 * variable slot for each formal parameter (the
438 * "procPtr->numCompiledLocals = numArgs" assignment below). This
439 * means that the same code can not be shared by two procedures that
440 * have a different number of arguments, even if their bodies are
441 * identical. Note that we don't use Tcl_DuplicateObj since we would
442 * not want any bytecode internal representation.
443 */
444
445 if (Tcl_IsShared(bodyPtr)) {
446 const char *bytes;
447 int length;
448 Tcl_Obj *sharedBodyPtr = bodyPtr;
449
450 bytes = TclGetStringFromObj(bodyPtr, &length);
451 bodyPtr = Tcl_NewStringObj(bytes, length);
452
453 /*
454 * TIP #280.
455 * Ensure that the continuation line data for the original body is
456 * not lost and applies to the new body as well.
457 */
458
459 TclContinuationsCopy(bodyPtr, sharedBodyPtr);
460 }
461
462 /*
463 * Create and initialize a Proc structure for the procedure. We
464 * increment the ref count of the procedure's body object since there
465 * will be a reference to it in the Proc structure.
466 */
467
468 Tcl_IncrRefCount(bodyPtr);
469
470 procPtr = (Proc *)ckalloc(sizeof(Proc));
471 procPtr->iPtr = iPtr;
472 procPtr->refCount = 1;
473 procPtr->bodyPtr = bodyPtr;
474 procPtr->numArgs = 0; /* Actual argument count is set below. */
475 procPtr->numCompiledLocals = 0;
476 procPtr->firstLocalPtr = NULL;
477 procPtr->lastLocalPtr = NULL;
478 }
479
480 /*
481 * Break up the argument list into argument specifiers, then process each
482 * argument specifier. If the body is precompiled, processing is limited
483 * to checking that the parsed argument is consistent with the one stored
484 * in the Proc.
485 */
486
487 result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray);
488 if (result != TCL_OK) {
489 goto procError;
490 }
491
492 if (precompiled) {
493 if (numArgs > procPtr->numArgs) {
494 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
495 "procedure \"%s\": arg list contains %d entries, "
496 "precompiled header expects %d", procName, numArgs,
497 procPtr->numArgs));
498 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
499 "BYTECODELIES", NULL);
500 goto procError;
501 }
502 localPtr = procPtr->firstLocalPtr;
503 } else {
504 procPtr->numArgs = numArgs;
505 procPtr->numCompiledLocals = numArgs;
506 }
507
508 for (i = 0; i < numArgs; i++) {
509 const char *argname, *argnamei, *argnamelast;
510 int fieldCount, nameLength;
511 Tcl_Obj **fieldValues;
512
513 /*
514 * Now divide the specifier up into name and default.
515 */
516
517 result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount,
518 &fieldValues);
519 if (result != TCL_OK) {
520 goto procError;
521 }
522 if (fieldCount > 2) {
523 Tcl_Obj *errorObj = Tcl_NewStringObj(
524 "too many fields in argument specifier \"", -1);
525 Tcl_AppendObjToObj(errorObj, argArray[i]);
526 Tcl_AppendToObj(errorObj, "\"", -1);
527 Tcl_SetObjResult(interp, errorObj);
528 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
529 "FORMALARGUMENTFORMAT", NULL);
530 goto procError;
531 }
532 if ((fieldCount == 0) || (fieldValues[0]->length == 0)) {
533 Tcl_SetObjResult(interp, Tcl_NewStringObj(
534 "argument with no name", -1));
535 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
536 "FORMALARGUMENTFORMAT", NULL);
537 goto procError;
538 }
539
540 argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);
541
542 /*
543 * Check that the formal parameter name is a scalar.
544 */
545
546 argnamei = argname;
547 argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;
548 while (argnamei < argnamelast) {
549 if (*argnamei == '(') {
550 if (*argnamelast == ')') { /* We have an array element. */
551 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
552 "formal parameter \"%s\" is an array element",
553 Tcl_GetString(fieldValues[0])));
554 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
555 "FORMALARGUMENTFORMAT", NULL);
556 goto procError;
557 }
558 } else if (*argnamei == ':' && *(argnamei+1) == ':') {
559 Tcl_Obj *errorObj = Tcl_NewStringObj(
560 "formal parameter \"", -1);
561 Tcl_AppendObjToObj(errorObj, fieldValues[0]);
562 Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
563 Tcl_SetObjResult(interp, errorObj);
564 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
565 "FORMALARGUMENTFORMAT", NULL);
566 goto procError;
567 }
568 argnamei++;
569 }
570
571 if (precompiled) {
572 /*
573 * Compare the parsed argument with the stored one. Note that the
574 * only flag value that makes sense at this point is VAR_ARGUMENT
575 * (its value was kept the same as pre VarReform to simplify
576 * tbcload's processing of older byetcodes).
577 *
578 * The only other flag vlaue that is important to retrieve from
579 * precompiled procs is VAR_TEMPORARY (also unchanged). It is
580 * needed later when retrieving the variable names.
581 */
582
583 if ((localPtr->nameLength != nameLength)
584 || (memcmp(localPtr->name, argname, nameLength) != 0)
585 || (localPtr->frameIndex != i)
586 || !(localPtr->flags & VAR_ARGUMENT)
587 || (localPtr->defValuePtr == NULL && fieldCount == 2)
588 || (localPtr->defValuePtr != NULL && fieldCount != 2)) {
589 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
590 "procedure \"%s\": formal parameter %d is "
591 "inconsistent with precompiled body", procName, i));
592 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
593 "BYTECODELIES", NULL);
594 goto procError;
595 }
596
597 /*
598 * Compare the default value if any.
599 */
600
601 if (localPtr->defValuePtr != NULL) {
602 const char *tmpPtr = TclGetString(localPtr->defValuePtr);
603 size_t tmpLength = localPtr->defValuePtr->length;
604 const char *value = TclGetString(fieldValues[1]);
605 size_t valueLength = fieldValues[1]->length;
606
607 if ((valueLength != tmpLength)
608 || memcmp(value, tmpPtr, tmpLength) != 0
609 ) {
610 Tcl_Obj *errorObj = Tcl_ObjPrintf(
611 "procedure \"%s\": formal parameter \"", procName);
612 Tcl_AppendObjToObj(errorObj, fieldValues[0]);
613 Tcl_AppendToObj(errorObj, "\" has "
614 "default value inconsistent with precompiled body", -1);
615 Tcl_SetObjResult(interp, errorObj);
616 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
617 "BYTECODELIES", NULL);
618 goto procError;
619 }
620 }
621 if ((i == numArgs - 1)
622 && (localPtr->nameLength == 4)
623 && (localPtr->name[0] == 'a')
624 && (strcmp(localPtr->name, "args") == 0)) {
625 localPtr->flags |= VAR_IS_ARGS;
626 }
627
628 localPtr = localPtr->nextPtr;
629 } else {
630 /*
631 * Allocate an entry in the runtime procedure frame's array of
632 * local variables for the argument.
633 */
634
635 localPtr = (CompiledLocal *)ckalloc(
636 offsetof(CompiledLocal, name) + fieldValues[0]->length + 1);
637 if (procPtr->firstLocalPtr == NULL) {
638 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
639 } else {
640 procPtr->lastLocalPtr->nextPtr = localPtr;
641 procPtr->lastLocalPtr = localPtr;
642 }
643 localPtr->nextPtr = NULL;
644 localPtr->nameLength = nameLength;
645 localPtr->frameIndex = i;
646 localPtr->flags = VAR_ARGUMENT;
647 localPtr->resolveInfo = NULL;
648
649 if (fieldCount == 2) {
650 localPtr->defValuePtr = fieldValues[1];
651 Tcl_IncrRefCount(localPtr->defValuePtr);
652 } else {
653 localPtr->defValuePtr = NULL;
654 }
655 memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
656 if ((i == numArgs - 1)
657 && (localPtr->nameLength == 4)
658 && (localPtr->name[0] == 'a')
659 && (memcmp(localPtr->name, "args", 4) == 0)) {
660 localPtr->flags |= VAR_IS_ARGS;
661 }
662 }
663 }
664
665 *procPtrPtr = procPtr;
666 return TCL_OK;
667
668 procError:
669 if (precompiled) {
670 procPtr->refCount--;
671 } else {
672 Tcl_DecrRefCount(bodyPtr);
673 while (procPtr->firstLocalPtr != NULL) {
674 localPtr = procPtr->firstLocalPtr;
675 procPtr->firstLocalPtr = localPtr->nextPtr;
676
677 if (localPtr->defValuePtr != NULL) {
678 Tcl_DecrRefCount(localPtr->defValuePtr);
679 }
680
681 ckfree(localPtr);
682 }
683 ckfree(procPtr);
684 }
685 return TCL_ERROR;
686 }
687
688 /*
689 *----------------------------------------------------------------------
690 *
691 * TclGetFrame --
692 *
693 * Given a description of a procedure frame, such as the first argument
694 * to an "uplevel" or "upvar" command, locate the call frame for the
695 * appropriate level of procedure.
696 *
697 * Results:
698 * The return value is -1 if an error occurred in finding the frame (in
699 * this case an error message is left in the interp's result). 1 is
700 * returned if string was either a number or a number preceded by "#" and
701 * it specified a valid frame. 0 is returned if string isn't one of the
702 * two things above (in this case, the lookup acts as if string were
703 * "1"). The variable pointed to by framePtrPtr is filled in with the
704 * address of the desired frame (unless an error occurs, in which case it
705 * isn't modified).
706 *
707 * Side effects:
708 * None.
709 *
710 *----------------------------------------------------------------------
711 */
712
713 int
TclGetFrame(Tcl_Interp * interp,const char * name,CallFrame ** framePtrPtr)714 TclGetFrame(
715 Tcl_Interp *interp, /* Interpreter in which to find frame. */
716 const char *name, /* String describing frame. */
717 CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
718 * global frame indicated). */
719 {
720 int result;
721 Tcl_Obj obj;
722
723 obj.bytes = (char *) name;
724 obj.length = strlen(name);
725 obj.typePtr = NULL;
726 result = TclObjGetFrame(interp, &obj, framePtrPtr);
727 TclFreeIntRep(&obj);
728 return result;
729 }
730
731 /*
732 *----------------------------------------------------------------------
733 *
734 * TclObjGetFrame --
735 *
736 * Given a description of a procedure frame, such as the first argument
737 * to an "uplevel" or "upvar" command, locate the call frame for the
738 * appropriate level of procedure.
739 *
740 * Results:
741 * The return value is -1 if an error occurred in finding the frame (in
742 * this case an error message is left in the interp's result). 1 is
743 * returned if objPtr was either an int or an int preceded by "#" and
744 * it specified a valid frame. 0 is returned if objPtr isn't one of the
745 * two things above (in this case, the lookup acts as if objPtr were
746 * "1"). The variable pointed to by framePtrPtr is filled in with the
747 * address of the desired frame (unless an error occurs, in which case it
748 * isn't modified).
749 *
750 * Side effects:
751 * None.
752 *
753 *----------------------------------------------------------------------
754 */
755
756 int
TclObjGetFrame(Tcl_Interp * interp,Tcl_Obj * objPtr,CallFrame ** framePtrPtr)757 TclObjGetFrame(
758 Tcl_Interp *interp, /* Interpreter in which to find frame. */
759 Tcl_Obj *objPtr, /* Object describing frame. */
760 CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
761 * global frame indicated). */
762 {
763 Interp *iPtr = (Interp *) interp;
764 int curLevel, level, result;
765 const Tcl_ObjIntRep *irPtr;
766 const char *name = NULL;
767 Tcl_WideInt w;
768
769 /*
770 * Parse object to figure out which level number to go to.
771 */
772
773 result = 0;
774 curLevel = iPtr->varFramePtr->level;
775
776 /*
777 * Check for integer first, since that has potential to spare us
778 * a generation of a stringrep.
779 */
780
781 if (objPtr == NULL) {
782 /* Do nothing */
783 } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) {
784 Tcl_GetWideIntFromObj(NULL, objPtr, &w);
785 if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) {
786 result = -1;
787 } else {
788 level = curLevel - level;
789 result = 1;
790 }
791 } else if ((irPtr = TclFetchIntRep(objPtr, &levelReferenceType))) {
792 level = irPtr->wideValue;
793 result = 1;
794 } else {
795 name = TclGetString(objPtr);
796 if (name[0] == '#') {
797 if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) {
798 if (level < 0 || (level > 0 && name[1] == '-')) {
799 result = -1;
800 } else {
801 Tcl_ObjIntRep ir;
802
803 ir.wideValue = level;
804 Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
805 result = 1;
806 }
807 } else {
808 result = -1;
809 }
810 } else if (TclGetWideBitsFromObj(NULL, objPtr, &w) == TCL_OK) {
811 /*
812 * If this were an integer, we'd have succeeded already.
813 * Docs say we have to treat this as a 'bad level' error.
814 */
815 result = -1;
816 }
817 }
818
819 if (result != -1) {
820 /* if relative current level */
821 if (result == 0) {
822 if (!curLevel) {
823 /* we are in top-level, so simply generate bad level */
824 name = "1";
825 goto badLevel;
826 }
827 level = curLevel - 1;
828 }
829 if (level >= 0) {
830 CallFrame *framePtr;
831 for (framePtr = iPtr->varFramePtr; framePtr != NULL;
832 framePtr = framePtr->callerVarPtr) {
833 if (framePtr->level == level) {
834 *framePtrPtr = framePtr;
835 return result;
836 }
837 }
838 }
839 }
840 badLevel:
841 if (name == NULL) {
842 name = objPtr ? TclGetString(objPtr) : "1" ;
843 }
844 Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
845 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
846 return -1;
847 }
848
849 /*
850 *----------------------------------------------------------------------
851 *
852 * Tcl_UplevelObjCmd --
853 *
854 * This object function is invoked to process the "uplevel" Tcl command.
855 * See the user documentation for details on what it does.
856 *
857 * Results:
858 * A standard Tcl object result value.
859 *
860 * Side effects:
861 * See the user documentation.
862 *
863 *----------------------------------------------------------------------
864 */
865
866 static int
Uplevel_Callback(ClientData data[],Tcl_Interp * interp,int result)867 Uplevel_Callback(
868 ClientData data[],
869 Tcl_Interp *interp,
870 int result)
871 {
872 CallFrame *savedVarFramePtr = (CallFrame *)data[0];
873
874 if (result == TCL_ERROR) {
875 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
876 "\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)));
877 }
878
879 /*
880 * Restore the variable frame, and return.
881 */
882
883 ((Interp *)interp)->varFramePtr = savedVarFramePtr;
884 return result;
885 }
886
887 int
Tcl_UplevelObjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])888 Tcl_UplevelObjCmd(
889 ClientData clientData,
890 Tcl_Interp *interp, /* Current interpreter. */
891 int objc, /* Number of arguments. */
892 Tcl_Obj *const objv[]) /* Argument objects. */
893 {
894 return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv);
895 }
896
897 int
TclNRUplevelObjCmd(TCL_UNUSED (ClientData),Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])898 TclNRUplevelObjCmd(
899 TCL_UNUSED(ClientData),
900 Tcl_Interp *interp, /* Current interpreter. */
901 int objc, /* Number of arguments. */
902 Tcl_Obj *const objv[]) /* Argument objects. */
903 {
904
905 Interp *iPtr = (Interp *) interp;
906 CmdFrame *invoker = NULL;
907 int word = 0;
908 int result;
909 CallFrame *savedVarFramePtr, *framePtr;
910 Tcl_Obj *objPtr;
911
912 if (objc < 2) {
913 /* to do
914 * simplify things by interpreting the argument as a command when there
915 * is only one argument. This requires a TIP since currently a single
916 * argument is interpreted as a level indicator if possible.
917 */
918 uplevelSyntax:
919 Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
920 return TCL_ERROR;
921 } else if (!TclHasStringRep(objv[1]) && objc == 2) {
922 int status ,llength;
923 status = Tcl_ListObjLength(interp, objv[1], &llength);
924 if (status == TCL_OK && llength > 1) {
925 /* the first argument can't interpreted as a level. Avoid
926 * generating a string representation of the script. */
927 result = TclGetFrame(interp, "1", &framePtr);
928 if (result == -1) {
929 return TCL_ERROR;
930 }
931 objc -= 1;
932 objv += 1;
933 goto havelevel;
934 }
935 }
936
937 /*
938 * Find the level to use for executing the command.
939 */
940
941 result = TclObjGetFrame(interp, objv[1], &framePtr);
942 if (result == -1) {
943 return TCL_ERROR;
944 }
945 objc -= result + 1;
946 if (objc == 0) {
947 goto uplevelSyntax;
948 }
949 objv += result + 1;
950
951 havelevel:
952
953 /*
954 * Modify the interpreter state to execute in the given frame.
955 */
956
957 savedVarFramePtr = iPtr->varFramePtr;
958 iPtr->varFramePtr = framePtr;
959
960 /*
961 * Execute the residual arguments as a command.
962 */
963
964 if (objc == 1) {
965 /*
966 * TIP #280. Make actual argument location available to eval'd script
967 */
968
969 TclArgumentGet(interp, objv[0], &invoker, &word);
970 objPtr = objv[0];
971
972 } else {
973 /*
974 * More than one argument: concatenate them together with spaces
975 * between, then evaluate the result. Tcl_EvalObjEx will delete the
976 * object when it decrements its refcount after eval'ing it.
977 */
978
979 objPtr = Tcl_ConcatObj(objc, objv);
980 }
981
982 TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
983 NULL);
984 return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
985 }
986
987 /*
988 *----------------------------------------------------------------------
989 *
990 * TclFindProc --
991 *
992 * Given the name of a procedure, return a pointer to the record
993 * describing the procedure. The procedure will be looked up using the
994 * usual rules: first in the current namespace and then in the global
995 * namespace.
996 *
997 * Results:
998 * NULL is returned if the name doesn't correspond to any procedure.
999 * Otherwise, the return value is a pointer to the procedure's record. If
1000 * the name is found but refers to an imported command that points to a
1001 * "real" procedure defined in another namespace, a pointer to that
1002 * "real" procedure's structure is returned.
1003 *
1004 * Side effects:
1005 * None.
1006 *
1007 *----------------------------------------------------------------------
1008 */
1009
1010 Proc *
TclFindProc(Interp * iPtr,const char * procName)1011 TclFindProc(
1012 Interp *iPtr, /* Interpreter in which to look. */
1013 const char *procName) /* Name of desired procedure. */
1014 {
1015 Tcl_Command cmd;
1016 Command *cmdPtr;
1017
1018 cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, NULL, /*flags*/ 0);
1019 if (cmd == (Tcl_Command) NULL) {
1020 return NULL;
1021 }
1022 cmdPtr = (Command *) cmd;
1023
1024 return TclIsProc(cmdPtr);
1025 }
1026
1027 /*
1028 *----------------------------------------------------------------------
1029 *
1030 * TclIsProc --
1031 *
1032 * Tells whether a command is a Tcl procedure or not.
1033 *
1034 * Results:
1035 * If the given command is actually a Tcl procedure, the return value is
1036 * the address of the record describing the procedure. Otherwise the
1037 * return value is 0.
1038 *
1039 * Side effects:
1040 * None.
1041 *
1042 *----------------------------------------------------------------------
1043 */
1044
1045 Proc *
TclIsProc(Command * cmdPtr)1046 TclIsProc(
1047 Command *cmdPtr) /* Command to test. */
1048 {
1049 Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
1050
1051 if (origCmd != NULL) {
1052 cmdPtr = (Command *) origCmd;
1053 }
1054 if (cmdPtr->deleteProc == TclProcDeleteProc) {
1055 return (Proc *)cmdPtr->objClientData;
1056 }
1057 return NULL;
1058 }
1059
1060 static int
ProcWrongNumArgs(Tcl_Interp * interp,int skip)1061 ProcWrongNumArgs(
1062 Tcl_Interp *interp,
1063 int skip)
1064 {
1065 CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
1066 Proc *procPtr = framePtr->procPtr;
1067 int localCt = procPtr->numCompiledLocals, numArgs, i;
1068 Tcl_Obj **desiredObjs;
1069 const char *final = NULL;
1070
1071 /*
1072 * Build up desired argument list for Tcl_WrongNumArgs
1073 */
1074
1075 numArgs = framePtr->procPtr->numArgs;
1076 desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
1077 sizeof(Tcl_Obj *) * (numArgs+1));
1078
1079 if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
1080 desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
1081 } else {
1082 #ifdef AVOID_HACKS_FOR_ITCL
1083 desiredObjs[0] = framePtr->objv[skip-1];
1084 #else
1085 desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1);
1086 #endif /* AVOID_HACKS_FOR_ITCL */
1087 }
1088 Tcl_IncrRefCount(desiredObjs[0]);
1089
1090 if (localCt > 0) {
1091 Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
1092
1093 for (i=1 ; i<=numArgs ; i++, defPtr++) {
1094 Tcl_Obj *argObj;
1095 Tcl_Obj *namePtr = localName(framePtr, i-1);
1096
1097 if (defPtr->value.objPtr != NULL) {
1098 TclNewObj(argObj);
1099 Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
1100 } else if (defPtr->flags & VAR_IS_ARGS) {
1101 numArgs--;
1102 final = "?arg ...?";
1103 break;
1104 } else {
1105 argObj = namePtr;
1106 Tcl_IncrRefCount(namePtr);
1107 }
1108 desiredObjs[i] = argObj;
1109 }
1110 }
1111
1112 Tcl_ResetResult(interp);
1113 Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);
1114
1115 for (i=0 ; i<=numArgs ; i++) {
1116 Tcl_DecrRefCount(desiredObjs[i]);
1117 }
1118 TclStackFree(interp, desiredObjs);
1119 return TCL_ERROR;
1120 }
1121
1122 /*
1123 *----------------------------------------------------------------------
1124 *
1125 * TclInitCompiledLocals --
1126 *
1127 * This routine is invoked in order to initialize the compiled locals
1128 * table for a new call frame.
1129 *
1130 * DEPRECATED: functionality has been inlined elsewhere; this function
1131 * remains to insure binary compatibility with Itcl.
1132 *
1133 * Results:
1134 * None.
1135 *
1136 * Side effects:
1137 * May invoke various name resolvers in order to determine which
1138 * variables are being referenced at runtime.
1139 *
1140 *----------------------------------------------------------------------
1141 */
1142
1143 void
TclInitCompiledLocals(Tcl_Interp * interp,CallFrame * framePtr,Namespace * nsPtr)1144 TclInitCompiledLocals(
1145 Tcl_Interp *interp, /* Current interpreter. */
1146 CallFrame *framePtr, /* Call frame to initialize. */
1147 Namespace *nsPtr) /* Pointer to current namespace. */
1148 {
1149 Var *varPtr = framePtr->compiledLocals;
1150 Tcl_Obj *bodyPtr;
1151 ByteCode *codePtr;
1152
1153 bodyPtr = framePtr->procPtr->bodyPtr;
1154 ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr);
1155 if (codePtr == NULL) {
1156 Tcl_Panic("body object for proc attached to frame is not a byte code type");
1157 }
1158
1159 if (framePtr->numCompiledLocals) {
1160 if (!codePtr->localCachePtr) {
1161 InitLocalCache(framePtr->procPtr) ;
1162 }
1163 framePtr->localCachePtr = codePtr->localCachePtr;
1164 framePtr->localCachePtr->refCount++;
1165 }
1166
1167 InitResolvedLocals(interp, codePtr, varPtr, nsPtr);
1168 }
1169
1170 /*
1171 *----------------------------------------------------------------------
1172 *
1173 * InitResolvedLocals --
1174 *
1175 * This routine is invoked in order to initialize the compiled locals
1176 * table for a new call frame.
1177 *
1178 * Results:
1179 * None.
1180 *
1181 * Side effects:
1182 * May invoke various name resolvers in order to determine which
1183 * variables are being referenced at runtime.
1184 *
1185 *----------------------------------------------------------------------
1186 */
1187
1188 static void
InitResolvedLocals(Tcl_Interp * interp,ByteCode * codePtr,Var * varPtr,Namespace * nsPtr)1189 InitResolvedLocals(
1190 Tcl_Interp *interp, /* Current interpreter. */
1191 ByteCode *codePtr,
1192 Var *varPtr,
1193 Namespace *nsPtr) /* Pointer to current namespace. */
1194 {
1195 Interp *iPtr = (Interp *) interp;
1196 int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
1197 CompiledLocal *firstLocalPtr, *localPtr;
1198 int varNum;
1199 Tcl_ResolvedVarInfo *resVarInfo;
1200
1201 /*
1202 * Find the localPtr corresponding to varPtr
1203 */
1204
1205 varNum = varPtr - iPtr->framePtr->compiledLocals;
1206 localPtr = iPtr->framePtr->procPtr->firstLocalPtr;
1207 while (varNum--) {
1208 localPtr = localPtr->nextPtr;
1209 }
1210
1211 if (!(haveResolvers && (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS))) {
1212 goto doInitResolvedLocals;
1213 }
1214
1215 /*
1216 * This is the first run after a recompile, or else the resolver epoch
1217 * has changed: update the resolver cache.
1218 */
1219
1220 firstLocalPtr = localPtr;
1221 for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
1222 if (localPtr->resolveInfo) {
1223 if (localPtr->resolveInfo->deleteProc) {
1224 localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
1225 } else {
1226 ckfree(localPtr->resolveInfo);
1227 }
1228 localPtr->resolveInfo = NULL;
1229 }
1230 localPtr->flags &= ~VAR_RESOLVED;
1231
1232 if (haveResolvers &&
1233 !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) {
1234 ResolverScheme *resPtr = iPtr->resolverPtr;
1235 Tcl_ResolvedVarInfo *vinfo;
1236 int result;
1237
1238 if (nsPtr->compiledVarResProc) {
1239 result = nsPtr->compiledVarResProc(nsPtr->interp,
1240 localPtr->name, localPtr->nameLength,
1241 (Tcl_Namespace *) nsPtr, &vinfo);
1242 } else {
1243 result = TCL_CONTINUE;
1244 }
1245
1246 while ((result == TCL_CONTINUE) && resPtr) {
1247 if (resPtr->compiledVarResProc) {
1248 result = resPtr->compiledVarResProc(nsPtr->interp,
1249 localPtr->name, localPtr->nameLength,
1250 (Tcl_Namespace *) nsPtr, &vinfo);
1251 }
1252 resPtr = resPtr->nextPtr;
1253 }
1254 if (result == TCL_OK) {
1255 localPtr->resolveInfo = vinfo;
1256 localPtr->flags |= VAR_RESOLVED;
1257 }
1258 }
1259 }
1260 localPtr = firstLocalPtr;
1261 codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS;
1262
1263 /*
1264 * Initialize the array of local variables stored in the call frame. Some
1265 * variables may have special resolution rules. In that case, we call
1266 * their "resolver" procs to get our hands on the variable, and we make
1267 * the compiled local a link to the real variable.
1268 */
1269
1270 doInitResolvedLocals:
1271 for (; localPtr != NULL; varPtr++, localPtr = localPtr->nextPtr) {
1272 varPtr->flags = 0;
1273 varPtr->value.objPtr = NULL;
1274
1275 /*
1276 * Now invoke the resolvers to determine the exact variables that
1277 * should be used.
1278 */
1279
1280 resVarInfo = localPtr->resolveInfo;
1281 if (resVarInfo && resVarInfo->fetchProc) {
1282 Var *resolvedVarPtr = (Var *)
1283 resVarInfo->fetchProc(interp, resVarInfo);
1284
1285 if (resolvedVarPtr) {
1286 if (TclIsVarInHash(resolvedVarPtr)) {
1287 VarHashRefCount(resolvedVarPtr)++;
1288 }
1289 varPtr->flags = VAR_LINK;
1290 varPtr->value.linkPtr = resolvedVarPtr;
1291 }
1292 }
1293 }
1294 }
1295
1296 void
TclFreeLocalCache(Tcl_Interp * interp,LocalCache * localCachePtr)1297 TclFreeLocalCache(
1298 Tcl_Interp *interp,
1299 LocalCache *localCachePtr)
1300 {
1301 int i;
1302 Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
1303
1304 for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
1305 Tcl_Obj *objPtr = *namePtrPtr;
1306
1307 if (objPtr) {
1308 /* TclReleaseLiteral calls Tcl_DecrRefCount for us */
1309 TclReleaseLiteral(interp, objPtr);
1310 }
1311 }
1312 ckfree(localCachePtr);
1313 }
1314
1315 static void
InitLocalCache(Proc * procPtr)1316 InitLocalCache(
1317 Proc *procPtr)
1318 {
1319 Interp *iPtr = procPtr->iPtr;
1320 ByteCode *codePtr;
1321 int localCt = procPtr->numCompiledLocals;
1322 int numArgs = procPtr->numArgs, i = 0;
1323
1324 Tcl_Obj **namePtr;
1325 Var *varPtr;
1326 LocalCache *localCachePtr;
1327 CompiledLocal *localPtr;
1328 int isNew;
1329
1330 ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
1331
1332 /*
1333 * Cache the names and initial values of local variables; store the
1334 * cache in both the framePtr for this execution and in the codePtr
1335 * for future calls.
1336 */
1337
1338 localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0)
1339 + localCt * sizeof(Tcl_Obj *)
1340 + numArgs * sizeof(Var));
1341
1342 namePtr = &localCachePtr->varName0;
1343 varPtr = (Var *) (namePtr + localCt);
1344 localPtr = procPtr->firstLocalPtr;
1345 while (localPtr) {
1346 if (TclIsVarTemporary(localPtr)) {
1347 *namePtr = NULL;
1348 } else {
1349 *namePtr = TclCreateLiteral(iPtr, localPtr->name,
1350 localPtr->nameLength, /* hash */ (unsigned int) -1,
1351 &isNew, /* nsPtr */ NULL, 0, NULL);
1352 Tcl_IncrRefCount(*namePtr);
1353 }
1354
1355 if (i < numArgs) {
1356 varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
1357 varPtr->value.objPtr = localPtr->defValuePtr;
1358 varPtr++;
1359 i++;
1360 }
1361 namePtr++;
1362 localPtr = localPtr->nextPtr;
1363 }
1364 codePtr->localCachePtr = localCachePtr;
1365 localCachePtr->refCount = 1;
1366 localCachePtr->numVars = localCt;
1367 }
1368
1369 /*
1370 *----------------------------------------------------------------------
1371 *
1372 * InitArgsAndLocals --
1373 *
1374 * This routine is invoked in order to initialize the arguments and other
1375 * compiled locals table for a new call frame.
1376 *
1377 * Results:
1378 * A standard Tcl result.
1379 *
1380 * Side effects:
1381 * Allocates memory on the stack for the compiled local variables, the
1382 * caller is responsible for freeing them. Initialises all variables. May
1383 * invoke various name resolvers in order to determine which variables
1384 * are being referenced at runtime.
1385 *
1386 *----------------------------------------------------------------------
1387 */
1388
1389 static int
InitArgsAndLocals(Tcl_Interp * interp,int skip)1390 InitArgsAndLocals(
1391 Tcl_Interp *interp,/* Interpreter in which procedure was
1392 * invoked. */
1393 int skip) /* Number of initial arguments to be skipped,
1394 * i.e., words in the "command name". */
1395 {
1396 CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
1397 Proc *procPtr = framePtr->procPtr;
1398 ByteCode *codePtr;
1399 Var *varPtr, *defPtr;
1400 int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
1401 Tcl_Obj *const *argObjs;
1402
1403 ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
1404
1405 /*
1406 * Make sure that the local cache of variable names and initial values has
1407 * been initialised properly .
1408 */
1409
1410 if (localCt) {
1411 if (!codePtr->localCachePtr) {
1412 InitLocalCache(procPtr) ;
1413 }
1414 framePtr->localCachePtr = codePtr->localCachePtr;
1415 framePtr->localCachePtr->refCount++;
1416 defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
1417 } else {
1418 defPtr = NULL;
1419 }
1420
1421 /*
1422 * Create the "compiledLocals" array. Make sure it is large enough to hold
1423 * all the procedure's compiled local variables, including its formal
1424 * parameters.
1425 */
1426
1427 varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var));
1428 framePtr->compiledLocals = varPtr;
1429 framePtr->numCompiledLocals = localCt;
1430
1431 /*
1432 * Match and assign the call's actual parameters to the procedure's formal
1433 * arguments. The formal arguments are described by the first numArgs
1434 * entries in both the Proc structure's local variable list and the call
1435 * frame's local variable array.
1436 */
1437
1438 numArgs = procPtr->numArgs;
1439 argCt = framePtr->objc - skip; /* Set it to the number of args to the
1440 * procedure. */
1441 argObjs = framePtr->objv + skip;
1442 if (numArgs == 0) {
1443 if (argCt) {
1444 goto incorrectArgs;
1445 } else {
1446 goto correctArgs;
1447 }
1448 }
1449 imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
1450 for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
1451 /*
1452 * "Normal" arguments; last formal is special, depends on it being
1453 * 'args'.
1454 */
1455
1456 Tcl_Obj *objPtr = argObjs[i];
1457
1458 varPtr->flags = 0;
1459 varPtr->value.objPtr = objPtr;
1460 Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
1461 }
1462 for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
1463 /*
1464 * This loop is entered if argCt < (numArgs-1). Set default values;
1465 * last formal is special.
1466 */
1467
1468 Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL;
1469
1470 if (!objPtr) {
1471 goto incorrectArgs;
1472 }
1473 varPtr->flags = 0;
1474 varPtr->value.objPtr = objPtr;
1475 Tcl_IncrRefCount(objPtr); /* Local var reference. */
1476 }
1477
1478 /*
1479 * When we get here, the last formal argument remains to be defined:
1480 * defPtr and varPtr point to the last argument to be initialized.
1481 */
1482
1483 varPtr->flags = 0;
1484 if (defPtr && defPtr->flags & VAR_IS_ARGS) {
1485 Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i);
1486
1487 varPtr->value.objPtr = listPtr;
1488 Tcl_IncrRefCount(listPtr); /* Local var is a reference. */
1489 } else if (argCt == numArgs) {
1490 Tcl_Obj *objPtr = argObjs[i];
1491
1492 varPtr->value.objPtr = objPtr;
1493 Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
1494 } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) {
1495 Tcl_Obj *objPtr = defPtr->value.objPtr;
1496
1497 varPtr->value.objPtr = objPtr;
1498 Tcl_IncrRefCount(objPtr); /* Local var is a reference. */
1499 } else {
1500 goto incorrectArgs;
1501 }
1502 varPtr++;
1503
1504 /*
1505 * Initialise and resolve the remaining compiledLocals. In the absence of
1506 * resolvers, they are undefined local vars: (flags=0, value=NULL).
1507 */
1508
1509 correctArgs:
1510 if (numArgs < localCt) {
1511 if (!framePtr->nsPtr->compiledVarResProc
1512 && !((Interp *)interp)->resolverPtr) {
1513 memset(varPtr, 0, (localCt - numArgs)*sizeof(Var));
1514 } else {
1515 InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr);
1516 }
1517 }
1518
1519 return TCL_OK;
1520
1521 /*
1522 * Initialise all compiled locals to avoid problems at DeleteLocalVars.
1523 */
1524
1525 incorrectArgs:
1526 if ((skip != 1) &&
1527 TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) {
1528 TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
1529 }
1530 memset(varPtr, 0,
1531 ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
1532 return ProcWrongNumArgs(interp, skip);
1533 }
1534
1535 /*
1536 *----------------------------------------------------------------------
1537 *
1538 * TclPushProcCallFrame --
1539 *
1540 * Compiles a proc body if necessary, then pushes a CallFrame suitable
1541 * for executing it.
1542 *
1543 * Results:
1544 * A standard Tcl object result value.
1545 *
1546 * Side effects:
1547 * The proc's body may be recompiled. A CallFrame is pushed, it will have
1548 * to be popped by the caller.
1549 *
1550 *----------------------------------------------------------------------
1551 */
1552
1553 int
TclPushProcCallFrame(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[],int isLambda)1554 TclPushProcCallFrame(
1555 ClientData clientData, /* Record describing procedure to be
1556 * interpreted. */
1557 Tcl_Interp *interp,/* Interpreter in which procedure was
1558 * invoked. */
1559 int objc, /* Count of number of arguments to this
1560 * procedure. */
1561 Tcl_Obj *const objv[], /* Argument value objects. */
1562 int isLambda) /* 1 if this is a call by ApplyObjCmd: it
1563 * needs special rules for error msg */
1564 {
1565 Proc *procPtr = (Proc *)clientData;
1566 Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
1567 CallFrame *framePtr, **framePtrPtr;
1568 int result;
1569 ByteCode *codePtr;
1570
1571 /*
1572 * If necessary (i.e. if we haven't got a suitable compilation already
1573 * cached) compile the procedure's body. The compiler will allocate frame
1574 * slots for the procedure's non-argument local variables. Note that
1575 * compiling the body might increase procPtr->numCompiledLocals if new
1576 * local variables are found while compiling.
1577 */
1578
1579 ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
1580 if (codePtr != NULL) {
1581 Interp *iPtr = (Interp *) interp;
1582
1583 /*
1584 * When we've got bytecode, this is the check for validity. That is,
1585 * the bytecode must be for the right interpreter (no cross-leaks!),
1586 * the code must be from the current epoch (so subcommand compilation
1587 * is up-to-date), the namespace must match (so variable handling
1588 * is right) and the resolverEpoch must match (so that new shadowed
1589 * commands and/or resolver changes are considered).
1590 */
1591
1592 if (((Interp *) *codePtr->interpHandle != iPtr)
1593 || (codePtr->compileEpoch != iPtr->compileEpoch)
1594 || (codePtr->nsPtr != nsPtr)
1595 || (codePtr->nsEpoch != nsPtr->resolverEpoch)) {
1596 goto doCompilation;
1597 }
1598 } else {
1599 doCompilation:
1600 result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
1601 (isLambda ? "body of lambda term" : "body of proc"),
1602 TclGetString(objv[isLambda]));
1603 if (result != TCL_OK) {
1604 return result;
1605 }
1606 }
1607
1608 /*
1609 * Set up and push a new call frame for the new procedure invocation.
1610 * This call frame will execute in the proc's namespace, which might be
1611 * different than the current namespace. The proc's namespace is that of
1612 * its command, which can change if the command is renamed from one
1613 * namespace to another.
1614 */
1615
1616 framePtrPtr = &framePtr;
1617 (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
1618 (Tcl_Namespace *) nsPtr,
1619 (isLambda? (FRAME_IS_PROC|FRAME_IS_LAMBDA) : FRAME_IS_PROC));
1620
1621 framePtr->objc = objc;
1622 framePtr->objv = objv;
1623 framePtr->procPtr = procPtr;
1624
1625 return TCL_OK;
1626 }
1627
1628 /*
1629 *----------------------------------------------------------------------
1630 *
1631 * TclObjInterpProc --
1632 *
1633 * When a Tcl procedure gets invoked during bytecode evaluation, this
1634 * object-based routine gets invoked to interpret the procedure.
1635 *
1636 * Results:
1637 * A standard Tcl object result value.
1638 *
1639 * Side effects:
1640 * Depends on the commands in the procedure.
1641 *
1642 *----------------------------------------------------------------------
1643 */
1644
1645 int
TclObjInterpProc(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1646 TclObjInterpProc(
1647 ClientData clientData, /* Record describing procedure to be
1648 * interpreted. */
1649 Tcl_Interp *interp,/* Interpreter in which procedure was
1650 * invoked. */
1651 int objc, /* Count of number of arguments to this
1652 * procedure. */
1653 Tcl_Obj *const objv[]) /* Argument value objects. */
1654 {
1655 /*
1656 * Not used much in the core; external interface for iTcl
1657 */
1658
1659 return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv);
1660 }
1661
1662 int
TclNRInterpProc(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1663 TclNRInterpProc(
1664 ClientData clientData, /* Record describing procedure to be
1665 * interpreted. */
1666 Tcl_Interp *interp,/* Interpreter in which procedure was
1667 * invoked. */
1668 int objc, /* Count of number of arguments to this
1669 * procedure. */
1670 Tcl_Obj *const objv[]) /* Argument value objects. */
1671 {
1672 int result = TclPushProcCallFrame(clientData, interp, objc, objv,
1673 /*isLambda*/ 0);
1674
1675 if (result != TCL_OK) {
1676 return TCL_ERROR;
1677 }
1678 return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
1679 }
1680
1681 /*
1682 *----------------------------------------------------------------------
1683 *
1684 * TclNRInterpProcCore --
1685 *
1686 * When a Tcl procedure, lambda term or anything else that works like a
1687 * procedure gets invoked during bytecode evaluation, this object-based
1688 * routine gets invoked to interpret the body.
1689 *
1690 * Results:
1691 * A standard Tcl object result value.
1692 *
1693 * Side effects:
1694 * Nearly anything; depends on the commands in the procedure body.
1695 *
1696 *----------------------------------------------------------------------
1697 */
1698
1699 int
TclNRInterpProcCore(Tcl_Interp * interp,Tcl_Obj * procNameObj,int skip,ProcErrorProc * errorProc)1700 TclNRInterpProcCore(
1701 Tcl_Interp *interp,/* Interpreter in which procedure was
1702 * invoked. */
1703 Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
1704 int skip, /* Number of initial arguments to be skipped,
1705 * i.e., words in the "command name". */
1706 ProcErrorProc *errorProc) /* How to convert results from the script into
1707 * results of the overall procedure. */
1708 {
1709 Interp *iPtr = (Interp *) interp;
1710 Proc *procPtr = iPtr->varFramePtr->procPtr;
1711 int result;
1712 CallFrame *freePtr;
1713 ByteCode *codePtr;
1714
1715 result = InitArgsAndLocals(interp, skip);
1716 if (result != TCL_OK) {
1717 freePtr = iPtr->framePtr;
1718 Tcl_PopCallFrame(interp); /* Pop but do not free. */
1719 TclStackFree(interp, freePtr->compiledLocals);
1720 /* Free compiledLocals. */
1721 TclStackFree(interp, freePtr); /* Free CallFrame. */
1722 return TCL_ERROR;
1723 }
1724
1725 #if defined(TCL_COMPILE_DEBUG)
1726 if (tclTraceExec >= 1) {
1727 CallFrame *framePtr = iPtr->varFramePtr;
1728 int i;
1729
1730 if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
1731 fprintf(stdout, "Calling lambda ");
1732 } else {
1733 fprintf(stdout, "Calling proc ");
1734 }
1735 for (i = 0; i < framePtr->objc; i++) {
1736 TclPrintObject(stdout, framePtr->objv[i], 15);
1737 fprintf(stdout, " ");
1738 }
1739 fprintf(stdout, "\n");
1740 fflush(stdout);
1741 }
1742 #endif /*TCL_COMPILE_DEBUG*/
1743
1744 #ifdef USE_DTRACE
1745 if (TCL_DTRACE_PROC_ARGS_ENABLED()) {
1746 int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
1747 const char *a[10];
1748 int i;
1749
1750 for (i = 0 ; i < 10 ; i++) {
1751 a[i] = (l < iPtr->varFramePtr->objc ?
1752 TclGetString(iPtr->varFramePtr->objv[l]) : NULL);
1753 l++;
1754 }
1755 TCL_DTRACE_PROC_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
1756 a[8], a[9]);
1757 }
1758 if (TCL_DTRACE_PROC_INFO_ENABLED() && iPtr->cmdFramePtr) {
1759 Tcl_Obj *info = TclInfoFrame(interp, iPtr->cmdFramePtr);
1760 const char *a[6]; int i[2];
1761
1762 TclDTraceInfo(info, a, i);
1763 TCL_DTRACE_PROC_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
1764 TclDecrRefCount(info);
1765 }
1766 if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
1767 int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
1768
1769 TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
1770 TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
1771 iPtr->varFramePtr->objc - l - 1,
1772 (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
1773 }
1774 if (TCL_DTRACE_PROC_ENTRY_ENABLED()) {
1775 int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
1776
1777 TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ?
1778 TclGetString(iPtr->varFramePtr->objv[l]) : NULL,
1779 iPtr->varFramePtr->objc - l - 1,
1780 (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1));
1781 }
1782 #endif /* USE_DTRACE */
1783
1784 /*
1785 * Invoke the commands in the procedure's body.
1786 */
1787
1788 procPtr->refCount++;
1789 ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
1790
1791 TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
1792 NULL, NULL);
1793 return TclNRExecuteByteCode(interp, codePtr);
1794 }
1795
1796 static int
InterpProcNR2(ClientData data[],Tcl_Interp * interp,int result)1797 InterpProcNR2(
1798 ClientData data[],
1799 Tcl_Interp *interp,
1800 int result)
1801 {
1802 Interp *iPtr = (Interp *) interp;
1803 Proc *procPtr = iPtr->varFramePtr->procPtr;
1804 CallFrame *freePtr;
1805 Tcl_Obj *procNameObj = (Tcl_Obj *)data[0];
1806 ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
1807
1808 if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
1809 int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
1810
1811 TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
1812 TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
1813 }
1814 if (procPtr->refCount-- <= 1) {
1815 TclProcCleanupProc(procPtr);
1816 }
1817
1818 /*
1819 * Free the stack-allocated compiled locals and CallFrame. It is important
1820 * to pop the call frame without freeing it first: the compiledLocals
1821 * cannot be freed before the frame is popped, as the local variables must
1822 * be deleted. But the compiledLocals must be freed first, as they were
1823 * allocated later on the stack.
1824 */
1825
1826 if (result != TCL_OK) {
1827 goto process;
1828 }
1829
1830 done:
1831 if (TCL_DTRACE_PROC_RESULT_ENABLED()) {
1832 int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
1833 Tcl_Obj *r = Tcl_GetObjResult(interp);
1834
1835 TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ?
1836 TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result,
1837 TclGetString(r), r);
1838 }
1839
1840 freePtr = iPtr->framePtr;
1841 Tcl_PopCallFrame(interp); /* Pop but do not free. */
1842 TclStackFree(interp, freePtr->compiledLocals);
1843 /* Free compiledLocals. */
1844 TclStackFree(interp, freePtr); /* Free CallFrame. */
1845 return result;
1846
1847 /*
1848 * Process any non-TCL_OK result code.
1849 */
1850
1851 process:
1852 switch (result) {
1853 case TCL_RETURN:
1854 /*
1855 * If it is a 'return', do the TIP#90 processing now.
1856 */
1857
1858 result = TclUpdateReturnInfo((Interp *) interp);
1859 break;
1860
1861 case TCL_CONTINUE:
1862 case TCL_BREAK:
1863 /*
1864 * It's an error to get to this point from a 'break' or 'continue', so
1865 * transform to an error now.
1866 */
1867
1868 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1869 "invoked \"%s\" outside of a loop",
1870 ((result == TCL_BREAK) ? "break" : "continue")));
1871 Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
1872 result = TCL_ERROR;
1873
1874 /* FALLTHRU */
1875
1876 case TCL_ERROR:
1877 /*
1878 * Now it _must_ be an error, so we need to log it as such. This means
1879 * filling out the error trace. Luckily, we just hand this off to the
1880 * function handed to us as an argument.
1881 */
1882
1883 errorProc(interp, procNameObj);
1884 }
1885 goto done;
1886 }
1887
1888 /*
1889 *----------------------------------------------------------------------
1890 *
1891 * TclProcCompileProc --
1892 *
1893 * Called just before a procedure is executed to compile the body to byte
1894 * codes. If the type of the body is not "byte code" or if the compile
1895 * conditions have changed (namespace context, epoch counters, etc.) then
1896 * the body is recompiled. Otherwise, this function does nothing.
1897 *
1898 * Results:
1899 * None.
1900 *
1901 * Side effects:
1902 * May change the internal representation of the body object to compiled
1903 * code.
1904 *
1905 *----------------------------------------------------------------------
1906 */
1907
1908 int
TclProcCompileProc(Tcl_Interp * interp,Proc * procPtr,Tcl_Obj * bodyPtr,Namespace * nsPtr,const char * description,const char * procName)1909 TclProcCompileProc(
1910 Tcl_Interp *interp, /* Interpreter containing procedure. */
1911 Proc *procPtr, /* Data associated with procedure. */
1912 Tcl_Obj *bodyPtr, /* Body of proc. (Usually procPtr->bodyPtr,
1913 * but could be any code fragment compiled in
1914 * the context of this procedure.) */
1915 Namespace *nsPtr, /* Namespace containing procedure. */
1916 const char *description, /* string describing this body of code. */
1917 const char *procName) /* Name of this procedure. */
1918 {
1919 Interp *iPtr = (Interp *) interp;
1920 Tcl_CallFrame *framePtr;
1921 ByteCode *codePtr;
1922
1923 ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr);
1924
1925 /*
1926 * If necessary, compile the procedure's body. The compiler will allocate
1927 * frame slots for the procedure's non-argument local variables. If the
1928 * ByteCode already exists, make sure it hasn't been invalidated by
1929 * someone redefining a core command (this might make the compiled code
1930 * wrong). Also, if the code was compiled in/for a different interpreter,
1931 * we recompile it. Note that compiling the body might increase
1932 * procPtr->numCompiledLocals if new local variables are found while
1933 * compiling.
1934 *
1935 * Precompiled procedure bodies, however, are immutable and therefore they
1936 * are not recompiled, even if things have changed.
1937 */
1938
1939 if (codePtr != NULL) {
1940 if (((Interp *) *codePtr->interpHandle == iPtr)
1941 && (codePtr->compileEpoch == iPtr->compileEpoch)
1942 && (codePtr->nsPtr == nsPtr)
1943 && (codePtr->nsEpoch == nsPtr->resolverEpoch)) {
1944 return TCL_OK;
1945 }
1946
1947 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1948 if ((Interp *) *codePtr->interpHandle != iPtr) {
1949 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1950 "a precompiled script jumped interps", -1));
1951 Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
1952 "CROSSINTERPBYTECODE", NULL);
1953 return TCL_ERROR;
1954 }
1955 codePtr->compileEpoch = iPtr->compileEpoch;
1956 codePtr->nsPtr = nsPtr;
1957 } else {
1958 Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL);
1959 codePtr = NULL;
1960 }
1961 }
1962
1963 if (codePtr == NULL) {
1964 Tcl_HashEntry *hePtr;
1965
1966 #ifdef TCL_COMPILE_DEBUG
1967 if (tclTraceCompile >= 1) {
1968 /*
1969 * Display a line summarizing the top level command we are about
1970 * to compile.
1971 */
1972
1973 Tcl_Obj *message;
1974
1975 TclNewLiteralStringObj(message, "Compiling ");
1976 Tcl_IncrRefCount(message);
1977 Tcl_AppendStringsToObj(message, description, " \"", NULL);
1978 Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL);
1979 fprintf(stdout, "%s\"\n", TclGetString(message));
1980 Tcl_DecrRefCount(message);
1981 }
1982 #else
1983 (void)description;
1984 (void)procName;
1985 #endif
1986
1987 /*
1988 * Plug the current procPtr into the interpreter and coerce the code
1989 * body to byte codes. The interpreter needs to know which proc it's
1990 * compiling so that it can access its list of compiled locals.
1991 *
1992 * TRICKY NOTE: Be careful to push a call frame with the proper
1993 * namespace context, so that the byte codes are compiled in the
1994 * appropriate class context.
1995 */
1996
1997 iPtr->compiledProcPtr = procPtr;
1998
1999 if (procPtr->numCompiledLocals > procPtr->numArgs) {
2000 CompiledLocal *clPtr = procPtr->firstLocalPtr;
2001 CompiledLocal *lastPtr = NULL;
2002 int i, numArgs = procPtr->numArgs;
2003
2004 for (i = 0; i < numArgs; i++) {
2005 lastPtr = clPtr;
2006 clPtr = clPtr->nextPtr;
2007 }
2008
2009 if (lastPtr) {
2010 lastPtr->nextPtr = NULL;
2011 } else {
2012 procPtr->firstLocalPtr = NULL;
2013 }
2014 procPtr->lastLocalPtr = lastPtr;
2015 while (clPtr) {
2016 CompiledLocal *toFree = clPtr;
2017
2018 clPtr = clPtr->nextPtr;
2019 if (toFree->resolveInfo) {
2020 if (toFree->resolveInfo->deleteProc) {
2021 toFree->resolveInfo->deleteProc(toFree->resolveInfo);
2022 } else {
2023 ckfree(toFree->resolveInfo);
2024 }
2025 }
2026 ckfree(toFree);
2027 }
2028 procPtr->numCompiledLocals = procPtr->numArgs;
2029 }
2030
2031 (void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr,
2032 /* isProcCallFrame */ 0);
2033
2034 /*
2035 * TIP #280: We get the invoking context from the cmdFrame which
2036 * was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
2037 */
2038
2039 hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
2040
2041 /*
2042 * Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
2043 */
2044
2045 iPtr->invokeWord = 0;
2046 iPtr->invokeCmdFramePtr = hePtr ? (CmdFrame *)Tcl_GetHashValue(hePtr) : NULL;
2047 TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
2048 iPtr->invokeCmdFramePtr = NULL;
2049 TclPopStackFrame(interp);
2050 } else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
2051 /*
2052 * The resolver epoch has changed, but we only need to invalidate the
2053 * resolver cache.
2054 */
2055
2056 codePtr->nsEpoch = nsPtr->resolverEpoch;
2057 codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS;
2058 }
2059 return TCL_OK;
2060 }
2061
2062 /*
2063 *----------------------------------------------------------------------
2064 *
2065 * MakeProcError --
2066 *
2067 * Function called by TclObjInterpProc to create the stack information
2068 * upon an error from a procedure.
2069 *
2070 * Results:
2071 * The interpreter's error info trace is set to a value that supplements
2072 * the error code.
2073 *
2074 * Side effects:
2075 * none.
2076 *
2077 *----------------------------------------------------------------------
2078 */
2079
2080 static void
MakeProcError(Tcl_Interp * interp,Tcl_Obj * procNameObj)2081 MakeProcError(
2082 Tcl_Interp *interp, /* The interpreter in which the procedure was
2083 * called. */
2084 Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
2085 * messages and trace information. */
2086 {
2087 int overflow, limit = 60, nameLen;
2088 const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
2089
2090 overflow = (nameLen > limit);
2091 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
2092 "\n (procedure \"%.*s%s\" line %d)",
2093 (overflow ? limit : nameLen), procName,
2094 (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
2095 }
2096
2097 /*
2098 *----------------------------------------------------------------------
2099 *
2100 * TclProcDeleteProc --
2101 *
2102 * This function is invoked just before a command procedure is removed
2103 * from an interpreter. Its job is to release all the resources allocated
2104 * to the procedure.
2105 *
2106 * Results:
2107 * None.
2108 *
2109 * Side effects:
2110 * Memory gets freed, unless the procedure is actively being executed.
2111 * In this case the cleanup is delayed until the last call to the current
2112 * procedure completes.
2113 *
2114 *----------------------------------------------------------------------
2115 */
2116
2117 void
TclProcDeleteProc(ClientData clientData)2118 TclProcDeleteProc(
2119 ClientData clientData) /* Procedure to be deleted. */
2120 {
2121 Proc *procPtr = (Proc *)clientData;
2122
2123 if (procPtr->refCount-- <= 1) {
2124 TclProcCleanupProc(procPtr);
2125 }
2126 }
2127
2128 /*
2129 *----------------------------------------------------------------------
2130 *
2131 * TclProcCleanupProc --
2132 *
2133 * This function does all the real work of freeing up a Proc structure.
2134 * It's called only when the structure's reference count becomes zero.
2135 *
2136 * Results:
2137 * None.
2138 *
2139 * Side effects:
2140 * Memory gets freed.
2141 *
2142 *----------------------------------------------------------------------
2143 */
2144
2145 void
TclProcCleanupProc(Proc * procPtr)2146 TclProcCleanupProc(
2147 Proc *procPtr) /* Procedure to be deleted. */
2148 {
2149 CompiledLocal *localPtr;
2150 Tcl_Obj *bodyPtr = procPtr->bodyPtr;
2151 Tcl_Obj *defPtr;
2152 Tcl_ResolvedVarInfo *resVarInfo;
2153 Tcl_HashEntry *hePtr = NULL;
2154 CmdFrame *cfPtr = NULL;
2155 Interp *iPtr = procPtr->iPtr;
2156
2157 if (bodyPtr != NULL) {
2158 Tcl_DecrRefCount(bodyPtr);
2159 }
2160 for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
2161 CompiledLocal *nextPtr = localPtr->nextPtr;
2162
2163 resVarInfo = localPtr->resolveInfo;
2164 if (resVarInfo) {
2165 if (resVarInfo->deleteProc) {
2166 resVarInfo->deleteProc(resVarInfo);
2167 } else {
2168 ckfree(resVarInfo);
2169 }
2170 }
2171
2172 if (localPtr->defValuePtr != NULL) {
2173 defPtr = localPtr->defValuePtr;
2174 Tcl_DecrRefCount(defPtr);
2175 }
2176 ckfree(localPtr);
2177 localPtr = nextPtr;
2178 }
2179 ckfree(procPtr);
2180
2181 /*
2182 * TIP #280: Release the location data associated with this Proc
2183 * structure, if any. The interpreter may not exist (For example for
2184 * procbody structures created by tbcload.
2185 */
2186
2187 if (iPtr == NULL) {
2188 return;
2189 }
2190
2191 hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
2192 if (!hePtr) {
2193 return;
2194 }
2195
2196 cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
2197
2198 if (cfPtr) {
2199 if (cfPtr->type == TCL_LOCATION_SOURCE) {
2200 Tcl_DecrRefCount(cfPtr->data.eval.path);
2201 cfPtr->data.eval.path = NULL;
2202 }
2203 ckfree(cfPtr->line);
2204 cfPtr->line = NULL;
2205 ckfree(cfPtr);
2206 }
2207 Tcl_DeleteHashEntry(hePtr);
2208 }
2209
2210 /*
2211 *----------------------------------------------------------------------
2212 *
2213 * TclUpdateReturnInfo --
2214 *
2215 * This function is called when procedures return, and at other points
2216 * where the TCL_RETURN code is used. It examines the returnLevel and
2217 * returnCode to determine the real return status.
2218 *
2219 * Results:
2220 * The return value is the true completion code to use for the procedure
2221 * or script, instead of TCL_RETURN.
2222 *
2223 * Side effects:
2224 * None.
2225 *
2226 *----------------------------------------------------------------------
2227 */
2228
2229 int
TclUpdateReturnInfo(Interp * iPtr)2230 TclUpdateReturnInfo(
2231 Interp *iPtr) /* Interpreter for which TCL_RETURN exception
2232 * is being processed. */
2233 {
2234 int code = TCL_RETURN;
2235
2236 iPtr->returnLevel--;
2237 if (iPtr->returnLevel < 0) {
2238 Tcl_Panic("TclUpdateReturnInfo: negative return level");
2239 }
2240 if (iPtr->returnLevel == 0) {
2241 /*
2242 * Now we've reached the level to return the requested -code.
2243 * Since iPtr->returnLevel and iPtr->returnCode have completed
2244 * their task, we now reset them to default values so that any
2245 * bare "return TCL_RETURN" that may follow will work [Bug 2152286].
2246 */
2247
2248 code = iPtr->returnCode;
2249 iPtr->returnLevel = 1;
2250 iPtr->returnCode = TCL_OK;
2251 if (code == TCL_ERROR) {
2252 iPtr->flags |= ERR_LEGACY_COPY;
2253 }
2254 }
2255 return code;
2256 }
2257
2258 /*
2259 *----------------------------------------------------------------------
2260 *
2261 * TclGetObjInterpProc --
2262 *
2263 * Returns a pointer to the TclObjInterpProc function; this is different
2264 * from the value obtained from the TclObjInterpProc reference on systems
2265 * like Windows where import and export versions of a function exported
2266 * by a DLL exist.
2267 *
2268 * Results:
2269 * Returns the internal address of the TclObjInterpProc function.
2270 *
2271 * Side effects:
2272 * None.
2273 *
2274 *----------------------------------------------------------------------
2275 */
2276
2277 TclObjCmdProcType
TclGetObjInterpProc(void)2278 TclGetObjInterpProc(void)
2279 {
2280 return (TclObjCmdProcType) TclObjInterpProc;
2281 }
2282
2283 /*
2284 *----------------------------------------------------------------------
2285 *
2286 * TclNewProcBodyObj --
2287 *
2288 * Creates a new object, of type "procbody", whose internal
2289 * representation is the given Proc struct. The newly created object's
2290 * reference count is 0.
2291 *
2292 * Results:
2293 * Returns a pointer to a newly allocated Tcl_Obj, NULL on error.
2294 *
2295 * Side effects:
2296 * The reference count in the ByteCode attached to the Proc is bumped up
2297 * by one, since the internal rep stores a pointer to it.
2298 *
2299 *----------------------------------------------------------------------
2300 */
2301
2302 Tcl_Obj *
TclNewProcBodyObj(Proc * procPtr)2303 TclNewProcBodyObj(
2304 Proc *procPtr) /* the Proc struct to store as the internal
2305 * representation. */
2306 {
2307 Tcl_Obj *objPtr;
2308
2309 if (!procPtr) {
2310 return NULL;
2311 }
2312
2313 TclNewObj(objPtr);
2314 if (objPtr) {
2315 ProcSetIntRep(objPtr, procPtr);
2316 }
2317
2318 return objPtr;
2319 }
2320
2321 /*
2322 *----------------------------------------------------------------------
2323 *
2324 * ProcBodyDup --
2325 *
2326 * Tcl_ObjType's Dup function for the proc body object. Bumps the
2327 * reference count on the Proc stored in the internal representation.
2328 *
2329 * Results:
2330 * None.
2331 *
2332 * Side effects:
2333 * Sets up the object in dupPtr to be a duplicate of the one in srcPtr.
2334 *
2335 *----------------------------------------------------------------------
2336 */
2337
2338 static void
ProcBodyDup(Tcl_Obj * srcPtr,Tcl_Obj * dupPtr)2339 ProcBodyDup(
2340 Tcl_Obj *srcPtr, /* Object to copy. */
2341 Tcl_Obj *dupPtr) /* Target object for the duplication. */
2342 {
2343 Proc *procPtr;
2344 ProcGetIntRep(srcPtr, procPtr);
2345
2346 ProcSetIntRep(dupPtr, procPtr);
2347 }
2348
2349 /*
2350 *----------------------------------------------------------------------
2351 *
2352 * ProcBodyFree --
2353 *
2354 * Tcl_ObjType's Free function for the proc body object. The reference
2355 * count on its Proc struct is decreased by 1; if the count reaches 0,
2356 * the proc is freed.
2357 *
2358 * Results:
2359 * None.
2360 *
2361 * Side effects:
2362 * If the reference count on the Proc struct reaches 0, the struct is
2363 * freed.
2364 *
2365 *----------------------------------------------------------------------
2366 */
2367
2368 static void
ProcBodyFree(Tcl_Obj * objPtr)2369 ProcBodyFree(
2370 Tcl_Obj *objPtr) /* The object to clean up. */
2371 {
2372 Proc *procPtr;
2373
2374 ProcGetIntRep(objPtr, procPtr);
2375
2376 if (procPtr->refCount-- <= 1) {
2377 TclProcCleanupProc(procPtr);
2378 }
2379 }
2380
2381 /*
2382 *----------------------------------------------------------------------
2383 *
2384 * DupLambdaInternalRep, FreeLambdaInternalRep, SetLambdaFromAny --
2385 *
2386 * How to manage the internal representations of lambda term objects.
2387 * Syntactically they look like a two- or three-element list, where the
2388 * first element is the formal arguments, the second is the the body, and
2389 * the (optional) third is the namespace to execute the lambda term
2390 * within (the global namespace is assumed if it is absent).
2391 *
2392 *----------------------------------------------------------------------
2393 */
2394
2395 static void
DupLambdaInternalRep(Tcl_Obj * srcPtr,Tcl_Obj * copyPtr)2396 DupLambdaInternalRep(
2397 Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
2398 Tcl_Obj *copyPtr) /* Object with internal rep to set. */
2399 {
2400 Proc *procPtr;
2401 Tcl_Obj *nsObjPtr;
2402
2403 LambdaGetIntRep(srcPtr, procPtr, nsObjPtr);
2404 assert(procPtr != NULL);
2405
2406 procPtr->refCount++;
2407
2408 LambdaSetIntRep(copyPtr, procPtr, nsObjPtr);
2409 }
2410
2411 static void
FreeLambdaInternalRep(Tcl_Obj * objPtr)2412 FreeLambdaInternalRep(
2413 Tcl_Obj *objPtr) /* CmdName object with internal representation
2414 * to free. */
2415 {
2416 Proc *procPtr;
2417 Tcl_Obj *nsObjPtr;
2418
2419 LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
2420 assert(procPtr != NULL);
2421
2422 if (procPtr->refCount-- <= 1) {
2423 TclProcCleanupProc(procPtr);
2424 }
2425 TclDecrRefCount(nsObjPtr);
2426 }
2427
2428 static int
SetLambdaFromAny(Tcl_Interp * interp,Tcl_Obj * objPtr)2429 SetLambdaFromAny(
2430 Tcl_Interp *interp, /* Used for error reporting if not NULL. */
2431 Tcl_Obj *objPtr) /* The object to convert. */
2432 {
2433 Interp *iPtr = (Interp *) interp;
2434 const char *name;
2435 Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
2436 int isNew, objc, result;
2437 CmdFrame *cfPtr = NULL;
2438 Proc *procPtr;
2439
2440 if (interp == NULL) {
2441 return TCL_ERROR;
2442 }
2443
2444 /*
2445 * Convert objPtr to list type first; if it cannot be converted, or if its
2446 * length is not 2, then it cannot be converted to lambdaType.
2447 */
2448
2449 result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
2450 if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
2451 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2452 "can't interpret \"%s\" as a lambda expression",
2453 Tcl_GetString(objPtr)));
2454 Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
2455 return TCL_ERROR;
2456 }
2457
2458 argsPtr = objv[0];
2459 bodyPtr = objv[1];
2460
2461 /*
2462 * Create and initialize the Proc struct. The cmdPtr field is set to NULL
2463 * to signal that this is an anonymous function.
2464 */
2465
2466 name = TclGetString(objPtr);
2467
2468 if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, name, argsPtr, bodyPtr,
2469 &procPtr) != TCL_OK) {
2470 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
2471 "\n (parsing lambda expression \"%s\")", name));
2472 return TCL_ERROR;
2473 }
2474
2475 /*
2476 * CAREFUL: TclCreateProc returns refCount==1! [Bug 1578454]
2477 * procPtr->refCount = 1;
2478 */
2479
2480 procPtr->cmdPtr = NULL;
2481
2482 /*
2483 * TIP #280: Remember the line the apply body is starting on. In a Byte
2484 * code context we ask the engine to provide us with the necessary
2485 * information. This is for the initialization of the byte code compiler
2486 * when the body is used for the first time.
2487 *
2488 * NOTE: The body is the second word in the 'objPtr'. Its location,
2489 * accessible through 'context.line[1]' (see below) is therefore only the
2490 * first approximation of the actual line the body is on. We have to use
2491 * the string rep of the 'objPtr' to determine the exact line. This is
2492 * available already through 'name'. Use 'TclListLines', see 'switch'
2493 * (tclCmdMZ.c).
2494 *
2495 * This code is nearly identical to the #280 code in Tcl_ProcObjCmd, see
2496 * this file. The differences are the different index of the body in the
2497 * line array of the context, and the special processing mentioned in the
2498 * previous paragraph to track into the list. Find a way to factor the
2499 * common elements into a single function.
2500 */
2501
2502 if (iPtr->cmdFramePtr) {
2503 CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
2504
2505 *contextPtr = *iPtr->cmdFramePtr;
2506 if (contextPtr->type == TCL_LOCATION_BC) {
2507 /*
2508 * Retrieve the source context from the bytecode. This call
2509 * accounts for the reference to the source file, if any, held in
2510 * 'context.data.eval.path'.
2511 */
2512
2513 TclGetSrcInfoForPc(contextPtr);
2514 } else if (contextPtr->type == TCL_LOCATION_SOURCE) {
2515 /*
2516 * We created a new reference to the source file path name when we
2517 * created 'context' above. Account for the reference.
2518 */
2519
2520 Tcl_IncrRefCount(contextPtr->data.eval.path);
2521
2522 }
2523
2524 if (contextPtr->type == TCL_LOCATION_SOURCE) {
2525 /*
2526 * We can record source location within a lambda only if the body
2527 * was not created by substitution.
2528 */
2529
2530 if (contextPtr->line
2531 && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
2532 int buf[2];
2533
2534 /*
2535 * Move from approximation (line of list cmd word) to actual
2536 * location (line of 2nd list element).
2537 */
2538
2539 cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
2540 TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
2541
2542 cfPtr->level = -1;
2543 cfPtr->type = contextPtr->type;
2544 cfPtr->line = (int *)ckalloc(sizeof(int));
2545 cfPtr->line[0] = buf[1];
2546 cfPtr->nline = 1;
2547 cfPtr->framePtr = NULL;
2548 cfPtr->nextPtr = NULL;
2549
2550 cfPtr->data.eval.path = contextPtr->data.eval.path;
2551 Tcl_IncrRefCount(cfPtr->data.eval.path);
2552
2553 cfPtr->cmd = NULL;
2554 cfPtr->len = 0;
2555 }
2556
2557 /*
2558 * 'contextPtr' is going out of scope. Release the reference that
2559 * it's holding to the source file path
2560 */
2561
2562 Tcl_DecrRefCount(contextPtr->data.eval.path);
2563 }
2564 TclStackFree(interp, contextPtr);
2565 }
2566 Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr,
2567 &isNew), cfPtr);
2568
2569 /*
2570 * Set the namespace for this lambda: given by objv[2] understood as a
2571 * global reference, or else global per default.
2572 */
2573
2574 if (objc == 2) {
2575 TclNewLiteralStringObj(nsObjPtr, "::");
2576 } else {
2577 const char *nsName = TclGetString(objv[2]);
2578
2579 if ((*nsName != ':') || (*(nsName+1) != ':')) {
2580 TclNewLiteralStringObj(nsObjPtr, "::");
2581 Tcl_AppendObjToObj(nsObjPtr, objv[2]);
2582 } else {
2583 nsObjPtr = objv[2];
2584 }
2585 }
2586
2587 /*
2588 * Free the list internalrep of objPtr - this will free argsPtr, but
2589 * bodyPtr retains a reference from the Proc structure. Then finish the
2590 * conversion to lambdaType.
2591 */
2592
2593 LambdaSetIntRep(objPtr, procPtr, nsObjPtr);
2594 return TCL_OK;
2595 }
2596
2597 Proc *
TclGetLambdaFromObj(Tcl_Interp * interp,Tcl_Obj * objPtr,Tcl_Obj ** nsObjPtrPtr)2598 TclGetLambdaFromObj(
2599 Tcl_Interp *interp,
2600 Tcl_Obj *objPtr,
2601 Tcl_Obj **nsObjPtrPtr)
2602 {
2603 Proc *procPtr;
2604 Tcl_Obj *nsObjPtr;
2605
2606 LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
2607
2608 if (procPtr == NULL) {
2609 if (SetLambdaFromAny(interp, objPtr) != TCL_OK) {
2610 return NULL;
2611 }
2612 LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
2613 }
2614
2615 assert(procPtr != NULL);
2616 if (procPtr->iPtr != (Interp *)interp) {
2617 return NULL;
2618 }
2619
2620 *nsObjPtrPtr = nsObjPtr;
2621 return procPtr;
2622 }
2623
2624 /*
2625 *----------------------------------------------------------------------
2626 *
2627 * Tcl_ApplyObjCmd --
2628 *
2629 * This object-based function is invoked to process the "apply" Tcl
2630 * command. See the user documentation for details on what it does.
2631 *
2632 * Results:
2633 * A standard Tcl object result value.
2634 *
2635 * Side effects:
2636 * Depends on the content of the lambda term (i.e., objv[1]).
2637 *
2638 *----------------------------------------------------------------------
2639 */
2640
2641 int
Tcl_ApplyObjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2642 Tcl_ApplyObjCmd(
2643 ClientData clientData,
2644 Tcl_Interp *interp, /* Current interpreter. */
2645 int objc, /* Number of arguments. */
2646 Tcl_Obj *const objv[]) /* Argument objects. */
2647 {
2648 return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, clientData, objc, objv);
2649 }
2650
2651 int
TclNRApplyObjCmd(TCL_UNUSED (ClientData),Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2652 TclNRApplyObjCmd(
2653 TCL_UNUSED(ClientData),
2654 Tcl_Interp *interp, /* Current interpreter. */
2655 int objc, /* Number of arguments. */
2656 Tcl_Obj *const objv[]) /* Argument objects. */
2657 {
2658 Proc *procPtr = NULL;
2659 Tcl_Obj *lambdaPtr, *nsObjPtr;
2660 int result;
2661 Tcl_Namespace *nsPtr;
2662 ApplyExtraData *extraPtr;
2663
2664 if (objc < 2) {
2665 Tcl_WrongNumArgs(interp, 1, objv, "lambdaExpr ?arg ...?");
2666 return TCL_ERROR;
2667 }
2668
2669 /*
2670 * Set lambdaPtr, convert it to tclLambdaType in the current interp if
2671 * necessary.
2672 */
2673
2674 lambdaPtr = objv[1];
2675 procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr);
2676
2677 if (procPtr == NULL) {
2678 return TCL_ERROR;
2679 }
2680
2681 /*
2682 * Push a call frame for the lambda namespace.
2683 * Note that TclObjInterpProc() will pop it.
2684 */
2685
2686 result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
2687 if (result != TCL_OK) {
2688 return TCL_ERROR;
2689 }
2690
2691 extraPtr = (ApplyExtraData *)TclStackAlloc(interp, sizeof(ApplyExtraData));
2692 memset(&extraPtr->cmd, 0, sizeof(Command));
2693 procPtr->cmdPtr = &extraPtr->cmd;
2694 extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
2695
2696 /*
2697 * TIP#280 (semi-)HACK!
2698 *
2699 * Using cmd.clientData to tell [info frame] how to render the lambdaPtr.
2700 * The InfoFrameCmd will detect this case by testing cmd.hPtr for NULL.
2701 * This condition holds here because of the memset() above, and nowhere
2702 * else (in the core). Regular commands always have a valid hPtr, and
2703 * lambda's never.
2704 */
2705
2706 extraPtr->efi.length = 1;
2707 extraPtr->efi.fields[0].name = "lambda";
2708 extraPtr->efi.fields[0].proc = NULL;
2709 extraPtr->efi.fields[0].clientData = lambdaPtr;
2710 extraPtr->cmd.clientData = &extraPtr->efi;
2711
2712 result = TclPushProcCallFrame(procPtr, interp, objc, objv, 1);
2713 if (result == TCL_OK) {
2714 TclNRAddCallback(interp, ApplyNR2, extraPtr, NULL, NULL, NULL);
2715 result = TclNRInterpProcCore(interp, objv[1], 2, &MakeLambdaError);
2716 }
2717 return result;
2718 }
2719
2720 static int
ApplyNR2(ClientData data[],Tcl_Interp * interp,int result)2721 ApplyNR2(
2722 ClientData data[],
2723 Tcl_Interp *interp,
2724 int result)
2725 {
2726 ApplyExtraData *extraPtr = (ApplyExtraData *)data[0];
2727
2728 TclStackFree(interp, extraPtr);
2729 return result;
2730 }
2731
2732 /*
2733 *----------------------------------------------------------------------
2734 *
2735 * MakeLambdaError --
2736 *
2737 * Function called by TclObjInterpProc to create the stack information
2738 * upon an error from a lambda term.
2739 *
2740 * Results:
2741 * The interpreter's error info trace is set to a value that supplements
2742 * the error code.
2743 *
2744 * Side effects:
2745 * none.
2746 *
2747 *----------------------------------------------------------------------
2748 */
2749
2750 static void
MakeLambdaError(Tcl_Interp * interp,Tcl_Obj * procNameObj)2751 MakeLambdaError(
2752 Tcl_Interp *interp, /* The interpreter in which the procedure was
2753 * called. */
2754 Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
2755 * messages and trace information. */
2756 {
2757 int overflow, limit = 60, nameLen;
2758 const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
2759
2760 overflow = (nameLen > limit);
2761 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
2762 "\n (lambda term \"%.*s%s\" line %d)",
2763 (overflow ? limit : nameLen), procName,
2764 (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
2765 }
2766
2767 /*
2768 *----------------------------------------------------------------------
2769 *
2770 * TclGetCmdFrameForProcedure --
2771 *
2772 * How to get the CmdFrame information for a procedure.
2773 *
2774 * Results:
2775 * A pointer to the CmdFrame (only guaranteed to be valid until the next
2776 * Tcl command is processed or the interpreter's state is otherwise
2777 * modified) or a NULL if the information is not available.
2778 *
2779 * Side effects:
2780 * none.
2781 *
2782 *----------------------------------------------------------------------
2783 */
2784
2785 CmdFrame *
TclGetCmdFrameForProcedure(Proc * procPtr)2786 TclGetCmdFrameForProcedure(
2787 Proc *procPtr) /* The procedure whose cmd-frame is to be
2788 * looked up. */
2789 {
2790 Tcl_HashEntry *hePtr;
2791
2792 if (procPtr == NULL || procPtr->iPtr == NULL) {
2793 return NULL;
2794 }
2795 hePtr = Tcl_FindHashEntry(procPtr->iPtr->linePBodyPtr, procPtr);
2796 if (hePtr == NULL) {
2797 return NULL;
2798 }
2799 return (CmdFrame *) Tcl_GetHashValue(hePtr);
2800 }
2801
2802 /*
2803 * Local Variables:
2804 * mode: c
2805 * c-basic-offset: 4
2806 * fill-column: 78
2807 * End:
2808 */
2809