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