Tcl Source Code

Changes On Branch aspect-tip288
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch aspect-tip288 Excluding Merge-Ins

This is equivalent to a diff from db8e7f06b4 to 323aaaabb8

2022-11-22
23:26
merge 8.7 check-in: e26048efb8 user: dgp tags: trunk, main
00:00
Rebase to latest 9.0 Leaf check-in: 323aaaabb8 user: jan.nijtmans tags: aspect-tip288
2022-11-21
23:54
Merge 8.7 check-in: db8e7f06b4 user: jan.nijtmans tags: trunk, main
23:54
TIP #650: New function Tcl_GetWideUIntFromObj() check-in: 5fb5ac7189 user: jan.nijtmans tags: core-8-branch
23:28
Remove TCL_OUT_LINE_COMPILE in favour of TCL_ERROR check-in: a16355dafa user: jan.nijtmans tags: trunk, main
2022-11-13
18:28
Rebase to 9.0 check-in: 0297eb42a4 user: jan.nijtmans tags: aspect-tip288

Changes to doc/proc.n.

27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64























65
66
67
68
69
70
71
If \fIname\fR includes any namespace qualifiers,
the procedure is created in the specified namespace.
\fIArgs\fR specifies the formal arguments to the
procedure.  It consists of a list, possibly empty, each of whose
elements specifies
one argument.  Each argument specifier is also a list with either
one or two fields.  If there is only a single field in the specifier
then it is the name of the argument; if there are two fields, then
the first is the argument name and the second is its default value.
Arguments with default values that are followed by non-defaulted
arguments become required arguments; enough actual arguments must be
supplied to allow all arguments up to and including the last required
formal argument.
.PP
When \fIname\fR is invoked a local variable
will be created for each of the formal arguments to the procedure; its
value will be the value of corresponding argument in the invoking command
or the argument's default value.
Actual arguments are assigned to formal arguments strictly in order.
Arguments with default values need not be
specified in a procedure invocation.  However, there must be enough
actual arguments for all the
formal arguments that do not have defaults, and there must not be any extra
actual arguments.
Arguments with default values that are followed by non-defaulted
arguments become de-facto required arguments, though this may change
in a future version of Tcl; portable code should ensure that all
optional arguments come after all required arguments.
.PP
There is one special case to permit procedures with
variable numbers of arguments.  If the last formal argument has the name
.QW \fBargs\fR ,
then a call to the procedure may contain more actual arguments
than the procedure has formal arguments.  In this case, all of the actual arguments
starting at the one that would be assigned to \fBargs\fR are combined into
a list (as if the \fBlist\fR command had been used); this combined value
is assigned to the local variable \fBargs\fR.
.PP























When \fIbody\fR is being executed, variable names normally refer to
local variables, which are created automatically when referenced and
deleted when the procedure returns.  One local variable is automatically
created for each of the procedure's arguments.
Other variables can only be accessed by invoking one of the \fBglobal\fR,
\fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands.
The current namespace when \fIbody\fR is executed will be the






|
|
<
|
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<


|







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







27
28
29
30
31
32
33
34
35

36












37




38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
If \fIname\fR includes any namespace qualifiers,
the procedure is created in the specified namespace.
\fIArgs\fR specifies the formal arguments to the
procedure.  It consists of a list, possibly empty, each of whose
elements specifies
one argument.  Each argument specifier is also a list with either
one or two fields.  If there is only a single field in the specifier
then it is the name of a required argument; if there are two fields, then
the first is the name of an optional argument and the second is its default value.

Required arguments may only be in the beginning and in the end of the argument list,












surrounding any optional arguments.




.PP
There is one special case to permit procedures with
variable numbers of arguments.  If one formal argument has the name
.QW \fBargs\fR ,
then a call to the procedure may contain more actual arguments
than the procedure has formal arguments.  In this case, all of the actual arguments
starting at the one that would be assigned to \fBargs\fR are combined into
a list (as if the \fBlist\fR command had been used); this combined value
is assigned to the local variable \fBargs\fR.
.PP
When \fIname\fR is invoked a local variable
will be created for each of the formal arguments to the procedure; its
value will be the value of corresponding argument in the invoking command
or the argument's default value.
.PP
Arguments with default values need not be
specified in a procedure invocation.  However, there must be enough
actual arguments for all the
formal arguments that do not have defaults, and there must not be any extra
actual arguments unless \fBargs\fR is present.
.PP
Actual arguments are assigned to formal arguments in the following order.
.IP
Required arguments to the left are assigned from left-to-right.
.IP
Required arguments to the right are assigned from right-to-left.
.IP
Optional arguments to the left of any "\fBargs\fR" are assigned from left-to-right.
.IP
Optional arguments to the right of any "\fBargs\fR" are assigned from right-to-left.
.IP
Any remaining arguments are assigned to "\fBargs\fR" if it exists, or it is an error to have remaining arguments.
.PP
When \fIbody\fR is being executed, variable names normally refer to
local variables, which are created automatically when referenced and
deleted when the procedure returns.  One local variable is automatically
created for each of the procedure's arguments.
Other variables can only be accessed by invoking one of the \fBglobal\fR,
\fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands.
The current namespace when \fIbody\fR is executed will be the

Changes to generic/tclProc.c.

407
408
409
410
411
412
413







414
415
416
417
418
419
420
    Interp *iPtr = (Interp *) interp;

    Proc *procPtr = NULL;
    Tcl_Size i, numArgs;
    CompiledLocal *localPtr = NULL;
    Tcl_Obj **argArray;
    int precompiled = 0, result;








    ProcGetInternalRep(bodyPtr, procPtr);
    if (procPtr != NULL) {
	/*
	 * Because the body is a TclProProcBody, the actual body is already
	 * compiled, and it is not shared with anyone else, so it's OK not to
	 * unshare it (as a matter of fact, it is bad to unshare it, because






>
>
>
>
>
>
>







407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
    Interp *iPtr = (Interp *) interp;

    Proc *procPtr = NULL;
    Tcl_Size i, numArgs;
    CompiledLocal *localPtr = NULL;
    Tcl_Obj **argArray;
    int precompiled = 0, result;
    /*
     * To report on bad arglists:
     *  - set to 1 when 0 and optional/args is found
     *  - set to 2 when 1 and required is found
     *  - error when 2 and optional/args is found
     */
    int arglistShape = 0, isArgs, seenArgs = 0;

    ProcGetInternalRep(bodyPtr, procPtr);
    if (procPtr != NULL) {
	/*
	 * Because the body is a TclProProcBody, the actual body is already
	 * compiled, and it is not shared with anyone else, so it's OK not to
	 * unshare it (as a matter of fact, it is bad to unshare it, because
537
538
539
540
541
542
543




























544
545
546
547
548
549
550
		    "argument with no name", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}

	argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);





























	/*
	 * Check that the formal parameter name is a scalar.
	 */

	argnamei = argname;
	argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
		    "argument with no name", -1));
	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
		    "FORMALARGUMENTFORMAT", NULL);
	    goto procError;
	}

	argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);
	isArgs = (nameLength == 4) && !strcmp(argname, "args");

	/*
	 * Reject invalid argspecs early
	 */
	if (fieldCount == 2 || isArgs) {
	    if (isArgs && seenArgs) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"repeated \"args\" in argument list", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"FORMALARGUMENTFORMAT", NULL);
		goto procError;
	    }
	    seenArgs = seenArgs || isArgs;
	    if (arglistShape == 0) {
		arglistShape = 1;
	    } else if (arglistShape == 2) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"required arg may not be in the middle", -1));
		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			"FORMALARGUMENTFORMAT", NULL);
		goto procError;
	    }
	} else {
	    if (arglistShape == 1) {
		arglistShape = 2;
	    }
	}

	/*
	 * Check that the formal parameter name is a scalar.
	 */

	argnamei = argname;
	argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
			"default value inconsistent with precompiled body", -1);
		    Tcl_SetObjResult(interp, errorObj);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "BYTECODELIES", NULL);
		    goto procError;
		}
	    }
	    if ((i == numArgs - 1)
		    && (localPtr->nameLength == 4)
		    && (localPtr->name[0] == 'a')
		    && (strcmp(localPtr->name, "args") == 0)) {
		localPtr->flags |= VAR_IS_ARGS;
	    }

	    localPtr = localPtr->nextPtr;
	} else {
	    /*
	     * Allocate an entry in the runtime procedure frame's array of






|
<
<
<







651
652
653
654
655
656
657
658



659
660
661
662
663
664
665
			"default value inconsistent with precompiled body", -1);
		    Tcl_SetObjResult(interp, errorObj);
		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
			    "BYTECODELIES", NULL);
		    goto procError;
		}
	    }
	    if (isArgs) {



		localPtr->flags |= VAR_IS_ARGS;
	    }

	    localPtr = localPtr->nextPtr;
	} else {
	    /*
	     * Allocate an entry in the runtime procedure frame's array of
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
	    if (fieldCount == 2) {
		localPtr->defValuePtr = fieldValues[1];
		Tcl_IncrRefCount(localPtr->defValuePtr);
	    } else {
		localPtr->defValuePtr = NULL;
	    }
	    memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
	    if ((i == numArgs - 1)
		    && (localPtr->nameLength == 4)
		    && (localPtr->name[0] == 'a')
		    && (memcmp(localPtr->name, "args", 4) == 0)) {
		localPtr->flags |= VAR_IS_ARGS;
	    }
	}
    }

    *procPtrPtr = procPtr;
    return TCL_OK;






|
<
<
<







683
684
685
686
687
688
689
690



691
692
693
694
695
696
697
	    if (fieldCount == 2) {
		localPtr->defValuePtr = fieldValues[1];
		Tcl_IncrRefCount(localPtr->defValuePtr);
	    } else {
		localPtr->defValuePtr = NULL;
	    }
	    memcpy(localPtr->name, argname, fieldValues[0]->length + 1);
	    if (isArgs) {



		localPtr->flags |= VAR_IS_ARGS;
	    }
	}
    }

    *procPtrPtr = procPtr;
    return TCL_OK;
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099

1100
1101

1102




1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
static int
ProcWrongNumArgs(
    Tcl_Interp *interp,
    int skip)
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    Proc *procPtr = framePtr->procPtr;
    int localCt = procPtr->numCompiledLocals, numArgs, i;
    Tcl_Obj **desiredObjs;
    const char *final = NULL;

    /*
     * Build up desired argument list for Tcl_WrongNumArgs
     */

    numArgs = framePtr->procPtr->numArgs;
    desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
	    sizeof(Tcl_Obj *) * (numArgs+1));

    if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
	desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
    } else {
	desiredObjs[0] = framePtr->objv[skip-1];
    }
    Tcl_IncrRefCount(desiredObjs[0]);

    if (localCt > 0) {
	Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt);

	for (i=1 ; i<=numArgs ; i++, defPtr++) {
	    Tcl_Obj *argObj;
	    Tcl_Obj *namePtr = localName(framePtr, i-1);

	    if (defPtr->value.objPtr != NULL) {
		TclNewObj(argObj);
		Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
	    } else if (defPtr->flags & VAR_IS_ARGS) {

		numArgs--;
		final = "?arg ...?";

		break;




	    } else {
		argObj = namePtr;
		Tcl_IncrRefCount(namePtr);
	    }
	    desiredObjs[i] = argObj;
	}
    }

    Tcl_ResetResult(interp);
    Tcl_WrongNumArgs(interp, numArgs+1, desiredObjs, final);

    for (i=0 ; i<=numArgs ; i++) {
	Tcl_DecrRefCount(desiredObjs[i]);
    }
    TclStackFree(interp, desiredObjs);
    return TCL_ERROR;
}

/*






|









|











|







>
|
|
>
|
>
>
>
>
|



|




|

|







1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
static int
ProcWrongNumArgs(
    Tcl_Interp *interp,
    int skip)
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    Proc *procPtr = framePtr->procPtr;
    int localCt = procPtr->numCompiledLocals, numArgs, i, i2 = 1;
    Tcl_Obj **desiredObjs;
    const char *final = NULL;

    /*
     * Build up desired argument list for Tcl_WrongNumArgs
     */

    numArgs = framePtr->procPtr->numArgs;
    desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
	    sizeof(Tcl_Obj *) * (numArgs+2));

    if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
	desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
    } else {
	desiredObjs[0] = framePtr->objv[skip-1];
    }
    Tcl_IncrRefCount(desiredObjs[0]);

    if (localCt > 0) {
	Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt);

	for (i=i2=1 ; i<=numArgs ; i++, i2++, defPtr++) {
	    Tcl_Obj *argObj;
	    Tcl_Obj *namePtr = localName(framePtr, i-1);

	    if (defPtr->value.objPtr != NULL) {
		TclNewObj(argObj);
		Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", NULL);
	    } else if (defPtr->flags & VAR_IS_ARGS) {
		/*
		 * Work around the list quoting in WrongNumArgs which we
		 * do not want for ?arg ...?.
		 */

	        TclNewLiteralStringObj(argObj, "?arg");
		desiredObjs[i2] = argObj;
		i2++;
	        TclNewLiteralStringObj(argObj, "...?");
            } else {
		argObj = namePtr;
		Tcl_IncrRefCount(namePtr);
	    }
	    desiredObjs[i2] = argObj;
	}
    }

    Tcl_ResetResult(interp);
    Tcl_WrongNumArgs(interp, i2, desiredObjs, final);

    for (i=0 ; i<i2 ; i++) {
	Tcl_DecrRefCount(desiredObjs[i]);
    }
    TclStackFree(interp, desiredObjs);
    return TCL_ERROR;
}

/*
1343
1344
1345
1346
1347
1348
1349
1350

1351




1352

1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367

1368
1369

1370
1371
1372
1373
1374
1375
1376
1377
1378


1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406

1407
1408
1409
1410
1411
1412
1413

1414
1415
1416
1417







1418
1419
1420





1421



1422
1423


1424
1425
1426
1427

1428
1429
1430
1431
1432







1433


1434

1435
1436

1437
1438
1439
1440

1441

1442
1443
1444
1445
1446

1447

1448

1449
1450

1451
1452
1453

1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480



1481
1482
1483
1484
1485
1486
1487
1488
1489
				 * invoked. */
    int skip)			/* Number of initial arguments to be skipped,
				 * i.e., words in the "command name". */
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    Proc *procPtr = framePtr->procPtr;
    ByteCode *codePtr;
    Var *varPtr, *defPtr;

    int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;




    Tcl_Obj *const *argObjs;


    ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);

    /*
     * Make sure that the local cache of variable names and initial values has
     * been initialised properly .
     */

    if (localCt) {
	if (!codePtr->localCachePtr) {
	    InitLocalCache(procPtr) ;
	}
	framePtr->localCachePtr = codePtr->localCachePtr;
	framePtr->localCachePtr->refCount++;
	defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);

    } else {
	defPtr = NULL;

    }

    /*
     * Create the "compiledLocals" array. Make sure it is large enough to hold
     * all the procedure's compiled local variables, including its formal
     * parameters.
     */

    varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var));


    framePtr->compiledLocals = varPtr;
    framePtr->numCompiledLocals = localCt;

    /*
     * Match and assign the call's actual parameters to the procedure's formal
     * arguments. The formal arguments are described by the first numArgs
     * entries in both the Proc structure's local variable list and the call
     * frame's local variable array.
     */

    numArgs = procPtr->numArgs;
    argCt = framePtr->objc - skip;	/* Set it to the number of args to the
					 * procedure. */
    if (numArgs == 0) {
	if (argCt) {
	    goto incorrectArgs;
	} else {
	    goto correctArgs;
	}
    }
    argObjs = framePtr->objv + skip;
    imax = ((argCt < numArgs-1) ? argCt : numArgs-1);
    for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) {
	/*
	 * "Normal" arguments; last formal is special, depends on it being
	 * 'args'.
	 */


	Tcl_Obj *objPtr = argObjs[i];

	varPtr->flags = 0;
	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
    }
    for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) {

	/*
	 * This loop is entered if argCt < (numArgs-1). Set default values;
	 * last formal is special.
	 */








	Tcl_Obj *objPtr = defPtr ? defPtr->value.objPtr : NULL;






	if (!objPtr) {



	    goto incorrectArgs;
	}


	varPtr->flags = 0;
	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);	/* Local var reference. */
    }


    /*
     * When we get here, the last formal argument remains to be defined:
     * defPtr and varPtr point to the last argument to be initialized.
     */










    varPtr->flags = 0;

    if (defPtr && defPtr->flags & VAR_IS_ARGS) {
	Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i);


	varPtr->value.objPtr = listPtr;
	Tcl_IncrRefCount(listPtr);	/* Local var is a reference. */
    } else if (argCt == numArgs) {

	Tcl_Obj *objPtr = argObjs[i];


	varPtr->value.objPtr = objPtr;
	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
    } else if ((argCt < numArgs) && defPtr && defPtr->value.objPtr) {
	Tcl_Obj *objPtr = defPtr->value.objPtr;



	varPtr->value.objPtr = objPtr;

	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */
    } else {

	goto incorrectArgs;
    }
    varPtr++;


    /*
     * Initialise and resolve the remaining compiledLocals. In the absence of
     * resolvers, they are undefined local vars: (flags=0, value=NULL).
     */

  correctArgs:
    if (numArgs < localCt) {
	if (!framePtr->nsPtr->compiledVarResProc
		&& !((Interp *)interp)->resolverPtr) {
	    memset(varPtr, 0, (localCt - numArgs)*sizeof(Var));
	} else {
	    InitResolvedLocals(interp, codePtr, varPtr, framePtr->nsPtr);
	}
    }

    return TCL_OK;

    /*
     * Initialise all compiled locals to avoid problems at DeleteLocalVars.
     */

  incorrectArgs:
    if ((skip != 1) &&
	    TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) {
	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
    }



    memset(varPtr, 0,
	    ((framePtr->compiledLocals + localCt)-varPtr) * sizeof(Var));
    return ProcWrongNumArgs(interp, skip);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushProcCallFrame --






|
>
|
>
>
>
>
|
>








|





|
>

|
>








|
>
>
|
|








<
|
<







|
|
<
|
<
|
|
|
>
|
|
|
|
|
|
|
>
|
|
<
|
>
>
>
>
>
>
>

|
|
>
>
>
>
>
|
>
>
>
|

>
>
|
<
|
|
>
|

|
<

>
>
>
>
>
>
>
|
>
>
|
>
|
<
>
|
<
|
|
>
|
>
|
|
<
<
|
>
|
>
|
>
|

>
|
|
<
>







|


|

|














>
>
>
|
|







1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433

1434

1435
1436
1437
1438
1439
1440
1441
1442
1443

1444

1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458

1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483

1484
1485
1486
1487
1488
1489

1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503

1504
1505

1506
1507
1508
1509
1510
1511
1512


1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523

1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
				 * invoked. */
    int skip)			/* Number of initial arguments to be skipped,
				 * i.e., words in the "command name". */
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    Proc *procPtr = framePtr->procPtr;
    ByteCode *codePtr;
    Var *nextVarPtr, *lastVarPtr, *localVarPtr, *nextDefPtr, *lastDefPtr;
    /* Total compiled locals, >= numArgs */
    int numLocals = procPtr->numCompiledLocals;
    /* Number of arguments taken */
    int numArgs = procPtr->numArgs;
    /* Number of arguments given */
    int argCt = framePtr->objc - skip;
    Tcl_Obj *const *nextArgObj;
    Tcl_Obj *const *lastArgObj;

    ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);

    /*
     * Make sure that the local cache of variable names and initial values has
     * been initialised properly .
     */

    if (numLocals) {
	if (!codePtr->localCachePtr) {
	    InitLocalCache(procPtr) ;
	}
	framePtr->localCachePtr = codePtr->localCachePtr;
	framePtr->localCachePtr->refCount++;
	nextDefPtr = (Var *) (&framePtr->localCachePtr->varName0 + numLocals);
	lastDefPtr = &nextDefPtr[numArgs-1];
    } else {
	nextDefPtr = NULL;
	lastDefPtr = NULL;
    }

    /*
     * Create the "compiledLocals" array. Make sure it is large enough to hold
     * all the procedure's compiled local variables, including its formal
     * parameters.
     */

    nextVarPtr = (Var *)TclStackAlloc(interp, numLocals * sizeof(Var));
    lastVarPtr = &nextVarPtr[numArgs-1];
    localVarPtr = &nextVarPtr[numArgs];
    framePtr->compiledLocals = nextVarPtr;
    framePtr->numCompiledLocals = numLocals;

    /*
     * Match and assign the call's actual parameters to the procedure's formal
     * arguments. The formal arguments are described by the first numArgs
     * entries in both the Proc structure's local variable list and the call
     * frame's local variable array.
     */


    nextArgObj = framePtr->objv + skip;

    if (numArgs == 0) {
	if (argCt) {
	    goto incorrectArgs;
	} else {
	    goto correctArgs;
	}
    }
    lastArgObj = &nextArgObj[argCt-1];


    /*

     * Required args, LHS
     */
    while ( (nextVarPtr <= lastVarPtr)
	 && !(nextDefPtr->flags & VAR_IS_ARGS)
	 && (nextDefPtr->value.objPtr == NULL) ) {
	if (nextArgObj > lastArgObj) goto incorrectArgs;	/* not enough args */
	nextVarPtr->flags = 0;
	nextVarPtr->value.objPtr = *(nextArgObj++);
	Tcl_IncrRefCount(nextVarPtr->value.objPtr);	/* Local var is a reference. */

	++nextVarPtr; ++nextDefPtr;
    }
    /*
     * Required args, RHS

     */
    while ( (nextVarPtr <= lastVarPtr)
	 && !(lastDefPtr->flags & VAR_IS_ARGS)
	 && (lastDefPtr->value.objPtr == NULL) ) {
	if (nextArgObj > lastArgObj) goto incorrectArgs;	/* not enough args */
	lastVarPtr->flags = 0;
	lastVarPtr->value.objPtr = *(lastArgObj--);
	Tcl_IncrRefCount(lastVarPtr->value.objPtr);	/* Local var is a reference. */

	--lastVarPtr; --lastDefPtr;
    }
    /*
     * Optional args, LHS
     */
    while ( (nextVarPtr <= lastVarPtr)
	 && !(nextDefPtr->flags & VAR_IS_ARGS) ) {
	Tcl_Obj * objPtr;
	if (nextArgObj > lastArgObj) {
	    objPtr = nextDefPtr->value.objPtr;	/* take default */
	} else {
	    objPtr = *(nextArgObj++);
	}
	if (objPtr == NULL) Tcl_Panic("oops LHS!");
	nextVarPtr->value.objPtr = objPtr;
	nextVarPtr->flags = 0;

	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */

	++nextVarPtr; ++nextDefPtr;
    }
    /*
     * Optional args, RHS

     */
    while ( (nextVarPtr <= lastVarPtr)
	 && !(lastDefPtr->flags & VAR_IS_ARGS) ) {
	Tcl_Obj * objPtr;
	if (nextArgObj > lastArgObj) {
	    objPtr = lastDefPtr->value.objPtr;	/* take default */
	} else {
	    objPtr = *(lastArgObj--);
	}
	if (objPtr == NULL) Tcl_Panic("oops RHS!");
	lastVarPtr->value.objPtr = objPtr;
	lastVarPtr->flags = 0;
	Tcl_IncrRefCount(objPtr);	/* Local var is a reference. */


	--lastVarPtr; --lastDefPtr;
    }

    /*
     * Args?
     */
    if (nextVarPtr < lastVarPtr) {
	Tcl_Panic("nextVarPtr < lastVarPtr!\n");
    }
    if (nextVarPtr == lastVarPtr) {


	if (!(nextDefPtr->flags & VAR_IS_ARGS)) {
	    goto incorrectArgs;
	}
	Tcl_Obj *listPtr = Tcl_NewListObj(1+lastArgObj-nextArgObj, nextArgObj);
	nextVarPtr->value.objPtr = listPtr;
	nextVarPtr->flags = 0;
	Tcl_IncrRefCount(listPtr);	/* Local var is a reference. */
    } else {
	if (nextArgObj <= lastArgObj) {
	    goto incorrectArgs;
	}

    }

    /*
     * Initialise and resolve the remaining compiledLocals. In the absence of
     * resolvers, they are undefined local vars: (flags=0, value=NULL).
     */

  correctArgs:
    if (numArgs < numLocals) {
	if (!framePtr->nsPtr->compiledVarResProc
		&& !((Interp *)interp)->resolverPtr) {
	    memset(localVarPtr, 0, (numLocals - numArgs)*sizeof(Var));
	} else {
	    InitResolvedLocals(interp, codePtr, localVarPtr, framePtr->nsPtr);
	}
    }

    return TCL_OK;

    /*
     * Initialise all compiled locals to avoid problems at DeleteLocalVars.
     */

  incorrectArgs:
    if ((skip != 1) &&
	    TclInitRewriteEnsemble(interp, skip-1, 0, framePtr->objv)) {
	TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
    }
    /*
     * Ensure all un-assigned vars are zeroed
     */
    memset(nextVarPtr, 0,
	    ((framePtr->compiledLocals + numLocals)-nextVarPtr) * sizeof(Var));
    return ProcWrongNumArgs(interp, skip);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPushProcCallFrame --

Changes to tests/proc-old.test.

196
197
198
199
200
201
202

203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
} {11 y-default z-default}
test proc-old-30.7 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    list [catch {tproc} msg] $msg
} {1 {wrong # args: should be "tproc x ?y? ?z?"}}

test proc-old-30.8 {arguments and defaults} {
    list [catch {
	proc tproc {x {y y-default} z} {
	    return [list $x $y $z]
	}
	tproc 2 3
    } msg] $msg
} {1 {wrong # args: should be "tproc x ?y? z"}}
test proc-old-30.9 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2 3 4 5
} {2 3 {4 5}}
test proc-old-30.10 {arguments and defaults} {






>

<
|
|
|
|
|
<







196
197
198
199
200
201
202
203
204

205
206
207
208
209

210
211
212
213
214
215
216
} {11 y-default z-default}
test proc-old-30.7 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    list [catch {tproc} msg] $msg
} {1 {wrong # args: should be "tproc x ?y? ?z?"}}
# Prior to TIP#288, this was an error
test proc-old-30.8 {arguments and defaults} {

    proc tproc {x {y y-default} z} {
        return [list $x $y $z]
    }
    tproc 2 3
} {2 y-default 3}

test proc-old-30.9 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2 3 4 5
} {2 3 {4 5}}
test proc-old-30.10 {arguments and defaults} {

Added tests/tip288.test.











































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
if {"::tcltest" ni [namespace children]} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

testConstraint procbodytest [expr {![catch {package require procbodytest}]}]
testConstraint memory	    [llength [info commands memory]]

set setup {
    proc x {a args b} {
        return "a=$a, args=$args, b=$b"
    }
    proc y {a {b x} args c} {
        return "a=$a, b=$b, args=$args, c=$c"
    }
}
set cleanup {rename x {}; rename y {}}

test tip288-1.1 {Error cases, repeated args} -body {
    proc z {a args args} {
    }
} -returnCodes error -result {repeated "args" in argument list}

test tip288-1.2 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body {
    x 1 2
} -result {a=1, args=, b=2}

test tip288-1.3 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body {
    x 1 2 3
} -result {a=1, args=2, b=3}

test tip288-1.4 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body {
    x 1
} -returnCodes error -result {wrong # args: should be "x a ?arg ...? b"}

test tip288-1.5 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body {
    y 1 2 3
} -result {a=1, b=2, args=, c=3}

test tip288-1.6 {Examples for TIP#288} -setup $setup -cleanup $cleanup -body {
    y 1 2
} -result {a=1, b=x, args=, c=2}

# This is now an error
test tip288-1.7 {Examples for TIP#288} -body {
    proc z {a {b x} c args} {
        return "a=$a, b=$b, c=$c, args=$args"
    }
} -returnCodes error -result {required arg may not be in the middle}

# A default value for "args" is still allowed but pointless
test tip288-1.8 {Examples for TIP#288} -body {
    proc z {a b {args {b}}} {
        return "a=$a, b=$b, args=$args"
    }
    z 1 2
} -result {a=1, b=2, args=}


set setup {
    proc x {a b {c _c} {d _d} args {e _e} {f _f} g h} {
        list a $a b $b c $c d $d e $e f $f g $g h $h args $args
    }
}
set cleanup {rename x {}}

test tip288-2.1 {Pathological arglist} -setup $setup -cleanup $cleanup -body {
    x 1 2 3
} -returnCodes error -result {wrong # args: should be "x a b ?c? ?d? ?arg ...? ?e? ?f? g h"}

set i 1
foreach {args result} {
        {1 2 3 4}               {a 1 b 2 c _c d _d e _e f _f g 3 h 4  args {}}
        {1 2 3 4 5}             {a 1 b 2 c 3  d _d e _e f _f g 4 h 5  args {}}
        {1 2 3 4 5 6}           {a 1 b 2 c 3  d 4  e _e f _f g 5 h 6  args {}}
        {1 2 3 4 5 6 7}         {a 1 b 2 c 3  d 4  e _e f 5  g 6 h 7  args {}}
        {1 2 3 4 5 6 7 8}       {a 1 b 2 c 3  d 4  e 5  f 6  g 7 h 8  args {}}
        {1 2 3 4 5 6 7 8 9}     {a 1 b 2 c 3  d 4  e 6  f 7  g 8 h 9  args 5}
        {1 2 3 4 5 6 7 8 9 0}   {a 1 b 2 c 3  d 4  e 7  f 8  g 9 h 0  args {5 6}}
} {
    test tip288-2.[incr i] {Pathological arglist} -setup $setup -cleanup $cleanup -body [
        list x {*}$args
    ] -result [list {*}$result]
}

set setup {
    proc stup {{chan stdout} text} {
        list chan $chan text $text
    }
}
set cleanup {rename stup {}}
set i 0
foreach {args code result} {
        {}             error {wrong # args: should be "stup ?chan? text"}
        {foo}          ok    {chan stdout text foo}
        {foo bar}      ok    {chan foo text bar}
        {foo bar baz}  error {wrong # args: should be "stup ?chan? text"}
} {
    test tip288-3.[incr i] {Pathological arglist} -setup $setup -cleanup $cleanup -body [
        list stup {*}$args
    ] -returnCodes $code -result $result
}