Diff
Not logged in

Differences From Artifact [077f20baf5]:

To Artifact [74546c28c9]:


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
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







-
+






-
+









-







/*
 * Prototypes for static functions in this file
 */

static void		DupLambdaInternalRep(Tcl_Obj *objPtr,
			    Tcl_Obj *copyPtr);
static void		FreeLambdaInternalRep(Tcl_Obj *objPtr);
static int		InitArgsAndLocals(Tcl_Interp *interp, int skip);
static int		InitArgsAndLocals(Tcl_Interp *interp, Tcl_Size skip);
static void		InitResolvedLocals(Tcl_Interp *interp,
			    ByteCode *codePtr, Var *defPtr,
			    Namespace *nsPtr);
static void		InitLocalCache(Proc *procPtr);
static void		ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr);
static void		ProcBodyFree(Tcl_Obj *objPtr);
static int		ProcWrongNumArgs(Tcl_Interp *interp, int skip);
static int		ProcWrongNumArgs(Tcl_Interp *interp, Tcl_Size skip);
static void		MakeProcError(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
static void		MakeLambdaError(Tcl_Interp *interp,
			    Tcl_Obj *procNameObj);
static int		SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);

static Tcl_NRPostProc ApplyNR2;
static Tcl_NRPostProc InterpProcNR2;
static Tcl_NRPostProc Uplevel_Callback;
static Tcl_ObjCmdProc NRInterpProc;

/*
 * The ProcBodyObjType type
 */

const Tcl_ObjType tclProcBodyType = {
    "procbody",			/* name for this type */
150
151
152
153
154
155
156
157

158
159
160
161
162
163
164
149
150
151
152
153
154
155

156
157
158
159
160
161
162
163







-
+







 *
 * Side effects:
 *	A new procedure gets created.
 *
 *----------------------------------------------------------------------
 */

#undef TclObjInterpProc
#undef TclObjInterpProc2
int
Tcl_ProcObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    Tcl_Size objc,		/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
208
209
210
211
212
213
214
215

216
217
218
219
220
221
222
207
208
209
210
211
212
213

214
215
216
217
218
219
220
221







-
+







	Tcl_AddErrorInfo(interp, "\n    (creating proc \"");
	Tcl_AddErrorInfo(interp, simpleName);
	Tcl_AddErrorInfo(interp, "\")");
	return TCL_ERROR;
    }

    cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
	TclObjInterpProc, NRInterpProc, procPtr, TclProcDeleteProc);
	TclObjInterpProc2, TclNRInterpProc, procPtr, TclProcDeleteProc);

    /*
     * Now initialize the new procedure's cmdPtr field. This will be used
     * later when the procedure is called to determine what namespace the
     * procedure will run in. This will be different than the current
     * namespace if the proc was renamed into a different namespace.
     */
773
774
775
776
777
778
779
780

781
782
783
784
785
786
787
772
773
774
775
776
777
778

779
780
781
782
783
784
785
786







-
+







TclObjGetFrame(
    Tcl_Interp *interp,		/* Interpreter in which to find frame. */
    Tcl_Obj *objPtr,		/* Object describing frame. */
    CallFrame **framePtrPtr)	/* Store pointer to frame here (or NULL if
				 * global frame indicated). */
{
    Interp *iPtr = (Interp *) interp;
    int curLevel;
    Tcl_Size curLevel;
    int result, level;
    const Tcl_ObjInternalRep *irPtr;
    const char *name = NULL;
    Tcl_WideInt w;

    /*
     * Parse object to figure out which level number to go to.
795
796
797
798
799
800
801
802

803
804
805

806
807
808
809

810
811
812
813
814
815
816
794
795
796
797
798
799
800

801
802
803

804
805
806
807

808
809
810
811
812
813
814
815







-
+


-
+



-
+







     * a generation of a stringrep.
     */

    if (objPtr == NULL) {
	/* Do nothing */
    } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) {
	TclGetWideIntFromObj(NULL, objPtr, &w);
	if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) {
	if (w < 0 || w > INT_MAX || curLevel > INT_MAX) {
	    result = -1;
	} else {
	    level = curLevel - level;
	    level = (int)curLevel - level;
	    result = 1;
	}
    } else if ((irPtr = TclFetchInternalRep(objPtr, &levelReferenceType))) {
	level = irPtr->wideValue;
	level = (int)irPtr->wideValue;
	result = 1;
    } else {
	name = TclGetString(objPtr);
	if (name[0] == '#') {
	    if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) {
		if (level < 0 || (level > 0 && name[1] == '-')) {
		    result = -1;
837
838
839
840
841
842
843
844

845
846
847
848
849
850
851
836
837
838
839
840
841
842

843
844
845
846
847
848
849
850







-
+







	/* if relative current level */
	if (result == 0) {
	    if (!curLevel) {
		/* we are in top-level, so simply generate bad level */
		name = "1";
		goto badLevel;
	    }
	    level = curLevel - 1;
	    level = (int)curLevel - 1;
	}
	if (level >= 0) {
	    CallFrame *framePtr;
	    for (framePtr = iPtr->varFramePtr; framePtr != NULL;
		    framePtr = framePtr->callerVarPtr) {
		if ((int)framePtr->level == level) {
		    *framePtrPtr = framePtr;
901
902
903
904
905
906
907
908

909
910
911

912
913
914
915
916
917
918

919
920
921
922
923
924

925
926
927
928
929
930
931
900
901
902
903
904
905
906

907
908
909

910
911
912
913
914
915
916

917
918
919
920
921
922

923
924
925
926
927
928
929
930







-
+


-
+






-
+





-
+







    return result;
}

int
Tcl_UplevelObjCmd(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv);
    return Tcl_NRCallObjProc2(interp, TclNRUplevelObjCmd, clientData, objc, objv);
}

int
TclNRUplevelObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{

    Interp *iPtr = (Interp *) interp;
    CmdFrame *invoker = NULL;
    int word = 0;
    Tcl_Size word = 0;
    int result;
    CallFrame *savedVarFramePtr, *framePtr;
    Tcl_Obj *objPtr;

    if (objc < 2) {
    /* to do
    *    simplify things by interpreting the argument as a command when there
1066
1067
1068
1069
1070
1071
1072
1073

1074
1075
1076
1077
1078
1079
1080
1081

1082
1083
1084
1085
1086
1087
1088
1065
1066
1067
1068
1069
1070
1071

1072
1073
1074
1075
1076
1077
1078
1079

1080
1081
1082
1083
1084
1085
1086
1087







-
+







-
+







{
    Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);

    if (origCmd != NULL) {
	cmdPtr = (Command *) origCmd;
    }
    if (cmdPtr->deleteProc == TclProcDeleteProc) {
	return (Proc *)cmdPtr->objClientData;
	return (Proc *)cmdPtr->objClientData2;
    }
    return NULL;
}

static int
ProcWrongNumArgs(
    Tcl_Interp *interp,
    int skip)
    Tcl_Size skip)
{
    CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
    Proc *procPtr = framePtr->procPtr;
    Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, i;
    Tcl_Obj **desiredObjs;
    const char *final = NULL;

1158
1159
1160
1161
1162
1163
1164
1165

1166
1167
1168
1169
1170
1171
1172
1157
1158
1159
1160
1161
1162
1163

1164
1165
1166
1167
1168
1169
1170
1171







-
+







    ByteCode *codePtr,
    Var *varPtr,
    Namespace *nsPtr)		/* Pointer to current namespace. */
{
    Interp *iPtr = (Interp *) interp;
    int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
    CompiledLocal *firstLocalPtr, *localPtr;
    int varNum;
    Tcl_Size varNum;
    Tcl_ResolvedVarInfo *resVarInfo;

    /*
     * Find the localPtr corresponding to varPtr
     */

    varNum = varPtr - iPtr->framePtr->compiledLocals;
1353
1354
1355
1356
1357
1358
1359
1360

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

1359
1360
1361
1362
1363
1364
1365
1366







-
+







 *----------------------------------------------------------------------
 */

static int
InitArgsAndLocals(
    Tcl_Interp *interp,		/* Interpreter in which procedure was
				 * invoked. */
    int skip)			/* Number of initial arguments to be skipped,
    Tcl_Size 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;
    Tcl_Size localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
1593
1594
1595
1596
1597
1598
1599
1600

1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615

1616
1617
1618
1619
1620

1621
1622
1623
1624
1625
1626
1627
1628

1629
1630
1631
1632
1633
1634
1635
1592
1593
1594
1595
1596
1597
1598

1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613

1614
1615
1616
1617
1618

1619
1620
1621
1622
1623
1624
1625
1626

1627
1628
1629
1630
1631
1632
1633
1634







-
+














-
+




-
+







-
+








    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjInterpProc --
 * TclObjInterpProc2/TclNRInterpProc --
 *
 *	When a Tcl procedure gets invoked during bytecode evaluation, this
 *	object-based routine gets invoked to interpret the procedure.
 *
 * Results:
 *	A standard Tcl object result value.
 *
 * Side effects:
 *	Depends on the commands in the procedure.
 *
 *----------------------------------------------------------------------
 */

int
TclObjInterpProc(
TclObjInterpProc2(
    void *clientData,		/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,		/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
    Tcl_Size objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    /*
     * Not used much in the core; external interface for iTcl
     */

    return Tcl_NRCallObjProc(interp, NRInterpProc, clientData, objc, objv);
    return Tcl_NRCallObjProc2(interp, TclNRInterpProc, clientData, objc, objv);
}

int
TclNRInterpProc(
    void *clientData,		/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,		/* Interpreter in which procedure was
1643
1644
1645
1646
1647
1648
1649

1650
1651
1652

1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668

1669
1670


1671
1672
1673

1674
1675

1676
1677
1678
1679
1680
1681
1682
1683

1684

1685


1686
1687
1688
1689
1690
1691
1692
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651

1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669


1670
1671
1672
1673

1674
1675

1676
1677
1678
1679
1680
1681
1682
1683

1684
1685
1686

1687
1688
1689
1690
1691
1692
1693
1694
1695







+


-
+
















+
-
-
+
+


-
+

-
+







-
+

+
-
+
+








    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

#ifndef TCL_NO_DEPRECATED
static int
NRInterpProc(
    void *clientData,		/* Record describing procedure to be
    void *clientData,	/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,		/* Interpreter in which procedure was
				 * invoked. */
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    int result = TclPushProcCallFrame(clientData, interp, objc, objv,
	    /*isLambda*/ 0);

    if (result != TCL_OK) {
	return TCL_ERROR;
    }
    return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}

#undef TclObjInterpProc
static int
ObjInterpProc2(
int
TclObjInterpProc(
    void *clientData,		/* Record describing procedure to be
				 * interpreted. */
    Tcl_Interp *interp,		/* Interpreter in which procedure was
    Tcl_Interp *interp, 	/* Interpreter in which procedure was
				 * invoked. */
    Tcl_Size objc,		/* Count of number of arguments to this
    int objc,			/* Count of number of arguments to this
				 * procedure. */
    Tcl_Obj *const objv[])	/* Argument value objects. */
{
    /*
     * Not used much in the core; external interface for iTcl
     */

    return Tcl_NRCallObjProc2(interp, TclNRInterpProc, clientData, objc, objv);
    return Tcl_NRCallObjProc(interp, NRInterpProc, clientData, objc, objv);
}
#endif /* TCL_NO_DEPRECATED */



/*
 *----------------------------------------------------------------------
 *
 * TclNRInterpProcCore --
 *
 *	When a Tcl procedure, lambda term or anything else that works like a
 *	procedure gets invoked during bytecode evaluation, this object-based
2002
2003
2004
2005
2006
2007
2008
2009

2010
2011
2012
2013
2014
2015
2016
2005
2006
2007
2008
2009
2010
2011

2012
2013
2014
2015
2016
2017
2018
2019







-
+







	 */

	iPtr->compiledProcPtr = procPtr;

	if (procPtr->numCompiledLocals > procPtr->numArgs) {
	    CompiledLocal *clPtr = procPtr->firstLocalPtr;
	    CompiledLocal *lastPtr = NULL;
	    int i, numArgs = procPtr->numArgs;
	    Tcl_Size i, numArgs = procPtr->numArgs;

	    for (i = 0; i < numArgs; i++) {
		lastPtr = clPtr;
		clPtr = clPtr->nextPtr;
	    }

	    if (lastPtr) {
2067
2068
2069
2070
2071
2072
2073
2074

2075
2076
2077
2078
2079
2080
2081
2070
2071
2072
2073
2074
2075
2076

2077
2078
2079
2080
2081
2082
2083
2084







-
+







}

/*
 *----------------------------------------------------------------------
 *
 * MakeProcError --
 *
 *	Function called by TclObjInterpProc to create the stack information
 *	Function called by TclObjInterpProc2 to create the stack information
 *	upon an error from a procedure.
 *
 * Results:
 *	The interpreter's error info trace is set to a value that supplements
 *	the error code.
 *
 * Side effects:
2269
2270
2271
2272
2273
2274
2275
2276

2277
2278
2279
2280
2281




2282
2283
2284

2285
2286
2287
2288
2289
2290
2291
2292

2293
2294
2295
2296
2297

2298
2299
2300
2301
2302

2303
2304
2305
2306
2307
2308
2309
2272
2273
2274
2275
2276
2277
2278

2279
2280




2281
2282
2283
2284
2285
2286

2287

2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305

2306
2307
2308
2309
2310
2311
2312
2313







-
+

-
-
-
-
+
+
+
+


-
+
-







+





+




-
+







    }
    return code;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetObjInterpProc/TclGetObjInterpProc2 --
 * TclGetObjInterpProc2 --
 *
 *	Returns a pointer to the TclObjInterpProc/ObjInterpProc2 functions;
 *	this is different from the value obtained from the TclObjInterpProc
 *	reference on systems like Windows where import and export versions
 *	of a function exported by a DLL exist.
 *	Returns a pointer to the TclObjInterpProc2 function; this is different
 *	from the value obtained from the TclObjInterpProc2 reference on systems
 *	like Windows where import and export versions of a function exported
 *	by a DLL exist.
 *
 * Results:
 *	Returns the internal address of the TclObjInterpProc/ObjInterpProc2
 *	Returns the internal address of the TclObjInterpProc2 function.
 *	functions.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#ifndef TCL_NO_DEPRECATED
Tcl_ObjCmdProc *
TclGetObjInterpProc(void)
{
    return TclObjInterpProc;
}
#endif /* TCL_NO_DEPRECATED */

Tcl_ObjCmdProc2 *
TclGetObjInterpProc2(void)
{
    return ObjInterpProc2;
    return TclObjInterpProc2;
}

/*
 *----------------------------------------------------------------------
 *
 * TclNewProcBodyObj --
 *
2669
2670
2671
2672
2673
2674
2675
2676

2677
2678
2679

2680
2681
2682
2683
2684
2685
2686

2687
2688
2689
2690
2691
2692
2693
2673
2674
2675
2676
2677
2678
2679

2680
2681
2682

2683
2684
2685
2686
2687
2688
2689

2690
2691
2692
2693
2694
2695
2696
2697







-
+


-
+






-
+







 *----------------------------------------------------------------------
 */

int
Tcl_ApplyObjCmd(
    void *clientData,
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, clientData, objc, objv);
    return Tcl_NRCallObjProc2(interp, TclNRApplyObjCmd, clientData, objc, objv);
}

int
TclNRApplyObjCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Size objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Proc *procPtr = NULL;
    Tcl_Obj *lambdaPtr, *nsObjPtr;
    int result;
    Tcl_Namespace *nsPtr;
    ApplyExtraData *extraPtr;
2707
2708
2709
2710
2711
2712
2713
2714

2715
2716
2717
2718
2719
2720
2721
2711
2712
2713
2714
2715
2716
2717

2718
2719
2720
2721
2722
2723
2724
2725







-
+








    if (procPtr == NULL) {
	return TCL_ERROR;
    }

    /*
     * Push a call frame for the lambda namespace.
     * Note that TclObjInterpProc() will pop it.
     * Note that TclObjInterpProc2() will pop it.
     */

    result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
    if (result != TCL_OK) {
	return TCL_ERROR;
    }

2761
2762
2763
2764
2765
2766
2767
2768

2769
2770
2771
2772
2773
2774
2775
2765
2766
2767
2768
2769
2770
2771

2772
2773
2774
2775
2776
2777
2778
2779







-
+







}

/*
 *----------------------------------------------------------------------
 *
 * MakeLambdaError --
 *
 *	Function called by TclObjInterpProc to create the stack information
 *	Function called by TclObjInterpProc2 to create the stack information
 *	upon an error from a lambda term.
 *
 * Results:
 *	The interpreter's error info trace is set to a value that supplements
 *	the error code.
 *
 * Side effects: