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