Tcl Source Code

Check-in [b16b6d856c]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki

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

Overview
Comment:Start of developing compilation for [uplevel]
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | compile-uplevel
Files: files | file ages | folders
SHA3-256: b16b6d856c24f874803b3e89a50aa22a5b98b7b46549ee3c2b9f67d2b1e71e01
User & Date: dkf 2025-06-26 10:45:06.804
Context
2025-06-26
13:12
Draft of instruction done... but crashes. check-in: 4af3554349 user: dkf tags: compile-uplevel
10:45
Start of developing compilation for [uplevel] check-in: b16b6d856c user: dkf tags: compile-uplevel
09:56
Merge 9.0 check-in: 52ff13f312 user: jan.nijtmans tags: trunk, main
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/tclBasic.c.
︙︙
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375

    {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	TclNRSubstObjCmd,	CMD_IS_SAFE},
    {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, CMD_IS_SAFE},
    {"tailcall",	NULL,			TclCompileTailcallCmd,	TclNRTailcallObjCmd,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
    {"throw",		Tcl_ThrowObjCmd,	TclCompileThrowCmd,	NULL,	CMD_IS_SAFE},
    {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"try",		Tcl_TryObjCmd,		TclCompileTryCmd,	TclNRTryObjCmd,	CMD_IS_SAFE},
    {"unset",		Tcl_UnsetObjCmd,	TclCompileUnsetCmd,	NULL,	CMD_IS_SAFE},
    {"uplevel",		Tcl_UplevelObjCmd,	NULL,			TclNRUplevelObjCmd,	CMD_IS_SAFE}, // TODO: compile
    {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	CMD_IS_SAFE},
    {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	CMD_IS_SAFE},
    {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	CMD_IS_SAFE},
    {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	CMD_IS_SAFE},
    {"yieldto",		NULL,			TclCompileYieldToCmd,	TclNRYieldToObjCmd,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},

    /*








|








361
362
363
364
365
366
367
368
369
370
371
372
373
374
375

    {"subst",		Tcl_SubstObjCmd,	TclCompileSubstCmd,	TclNRSubstObjCmd,	CMD_IS_SAFE},
    {"switch",		Tcl_SwitchObjCmd,	TclCompileSwitchCmd,	TclNRSwitchObjCmd, CMD_IS_SAFE},
    {"tailcall",	NULL,			TclCompileTailcallCmd,	TclNRTailcallObjCmd,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
    {"throw",		Tcl_ThrowObjCmd,	TclCompileThrowCmd,	NULL,	CMD_IS_SAFE},
    {"trace",		Tcl_TraceObjCmd,	NULL,			NULL,	CMD_IS_SAFE},
    {"try",		Tcl_TryObjCmd,		TclCompileTryCmd,	TclNRTryObjCmd,	CMD_IS_SAFE},
    {"unset",		Tcl_UnsetObjCmd,	TclCompileUnsetCmd,	NULL,	CMD_IS_SAFE},
    {"uplevel",		Tcl_UplevelObjCmd,	TclCompileUplevelCmd,	TclNRUplevelObjCmd,	CMD_IS_SAFE},
    {"upvar",		Tcl_UpvarObjCmd,	TclCompileUpvarCmd,	NULL,	CMD_IS_SAFE},
    {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	CMD_IS_SAFE},
    {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	CMD_IS_SAFE},
    {"yield",		NULL,			TclCompileYieldCmd,	TclNRYieldObjCmd,	CMD_IS_SAFE},
    {"yieldto",		NULL,			TclCompileYieldToCmd,	TclNRYieldToObjCmd,	CMD_IS_SAFE|CMD_COMPILES_EXPANDED},

    /*
︙︙
Changes to generic/tclCompCmdsSZ.c.
︙︙
4323
4324
4325
4326
4327
4328
4329





































4330
4331
4332
4333
4334
4335
4336

	}

	varTokenPtr = TokenAfter(varTokenPtr);
    }
    PUSH(			"");
    return TCL_OK;
}






































/*
 *----------------------------------------------------------------------
 *
 * TclCompileWhileCmd --
 *
 *	Procedure called to compile the "while" command.








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








4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373

	}

	varTokenPtr = TokenAfter(varTokenPtr);
    }
    PUSH(			"");
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileUplevelCmd --
 *
 *	Procedure called to compile the "uplevel" command.
 *
 * Results:
 *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
 *	evaluation to runtime.
 *
 * Side effects:
 *	Instructions are added to envPtr to execute the "uplevel" command at
 *	runtime.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileUplevelCmd(
    Tcl_Interp *interp,		/* Used for error reporting. */
    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
				 * created by Tcl_ParseCommand. */
    TCL_UNUSED(Command *),
    CompileEnv *envPtr)		/* Holds resulting instructions. */
{
    DefineLineInformation;	/* TIP #280 */
    Tcl_Size numWords = parsePtr->numWords;
    /* TODO: Consider support for compiling expanded args. */
    if (numWords != 3 || !EnvIsProc(envPtr)) {
	return TCL_ERROR;
    }

    // FIXME: Implement this!
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileWhileCmd --
 *
 *	Procedure called to compile the "while" command.
︙︙
Changes to generic/tclInt.h.
︙︙
3193
3194
3195
3196
3197
3198
3199

3200
3201
3202
3203
3204
3205
3206

MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;

MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;

MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;








>








3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207

MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclUplevelCallback;
MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;

MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
MODULE_SCOPE Tcl_NRPostProc TclNRCoroutineActivateCallback;
MODULE_SCOPE Tcl_ObjCmdProc TclNRTailcallObjCmd;
MODULE_SCOPE Tcl_NRPostProc TclNRTailcallEval;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
︙︙
3933
3934
3935
3936
3937
3938
3939

3940
3941
3942
3943
3944
3945
3946

MODULE_SCOPE CompileProc TclCompileStringTrimRCmd;
MODULE_SCOPE CompileProc TclCompileSubstCmd;
MODULE_SCOPE CompileProc TclCompileSwitchCmd;
MODULE_SCOPE CompileProc TclCompileTailcallCmd;
MODULE_SCOPE CompileProc TclCompileThrowCmd;
MODULE_SCOPE CompileProc TclCompileTryCmd;
MODULE_SCOPE CompileProc TclCompileUnsetCmd;

MODULE_SCOPE CompileProc TclCompileUpvarCmd;
MODULE_SCOPE CompileProc TclCompileVariableCmd;
MODULE_SCOPE CompileProc TclCompileWhileCmd;
MODULE_SCOPE CompileProc TclCompileYieldCmd;
MODULE_SCOPE CompileProc TclCompileYieldToCmd;
MODULE_SCOPE CompileProc TclCompileBasic0ArgCmd;
MODULE_SCOPE CompileProc TclCompileBasic1ArgCmd;








>








3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948

MODULE_SCOPE CompileProc TclCompileStringTrimRCmd;
MODULE_SCOPE CompileProc TclCompileSubstCmd;
MODULE_SCOPE CompileProc TclCompileSwitchCmd;
MODULE_SCOPE CompileProc TclCompileTailcallCmd;
MODULE_SCOPE CompileProc TclCompileThrowCmd;
MODULE_SCOPE CompileProc TclCompileTryCmd;
MODULE_SCOPE CompileProc TclCompileUnsetCmd;
MODULE_SCOPE CompileProc TclCompileUplevelCmd;
MODULE_SCOPE CompileProc TclCompileUpvarCmd;
MODULE_SCOPE CompileProc TclCompileVariableCmd;
MODULE_SCOPE CompileProc TclCompileWhileCmd;
MODULE_SCOPE CompileProc TclCompileYieldCmd;
MODULE_SCOPE CompileProc TclCompileYieldToCmd;
MODULE_SCOPE CompileProc TclCompileBasic0ArgCmd;
MODULE_SCOPE CompileProc TclCompileBasic1ArgCmd;
︙︙
Changes to generic/tclProc.c.
︙︙
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

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








|








46
47
48
49
50
51
52
53
54
55
56
57
58
59
60

			    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 TclUplevelCallback;
static Tcl_ObjCmdProc NRInterpProc;

/*
 * The ProcBodyObjType type
 */

const Tcl_ObjType tclProcBodyType = {
︙︙
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891

 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
Uplevel_Callback(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    CallFrame *savedVarFramePtr = (CallFrame *)data[0];

    if (result == TCL_ERROR) {








|
|








876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891

 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
TclUplevelCallback(
    void *data[],
    Tcl_Interp *interp,
    int result)
{
    CallFrame *savedVarFramePtr = (CallFrame *)data[0];

    if (result == TCL_ERROR) {
︙︙
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944


    if (objc < 2) {
    /* to do
    *    simplify things by interpreting the argument as a command when there
    *    is only one argument.  This requires a TIP since currently a single
    *    argument is interpreted as a level indicator if possible.
    */
    uplevelSyntax:
	Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
	return TCL_ERROR;
    } else if (!TclHasStringRep(objv[1]) && objc == 2) {
	int status;
	Tcl_Size llength;
	status = TclListObjLength(interp, objv[1], &llength);
	if (status == TCL_OK && llength > 1) {
	    /* the first argument can't interpreted as a level. Avoid
	     * generating a string representation of the script. */








|
<
<








928
929
930
931
932
933
934
935


936
937
938
939
940
941
942


    if (objc < 2) {
    /* to do
    *    simplify things by interpreting the argument as a command when there
    *    is only one argument.  This requires a TIP since currently a single
    *    argument is interpreted as a level indicator if possible.
    */
	goto uplevelSyntax;


    } else if (!TclHasStringRep(objv[1]) && objc == 2) {
	int status;
	Tcl_Size llength;
	status = TclListObjLength(interp, objv[1], &llength);
	if (status == TCL_OK && llength > 1) {
	    /* the first argument can't interpreted as a level. Avoid
	     * generating a string representation of the script. */
︙︙
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002



1003
1004
1005
1006
1007
1008
1009

    }
    objc -= result + 1;
    if (objc == 0) {
	goto uplevelSyntax;
    }
    objv += result + 1;

    havelevel:

    /*
     * Modify the interpreter state to execute in the given frame.
     */

    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = framePtr;

    /*
     * Execute the residual arguments as a command.
     */

    if (objc == 1) {
	/*
	 * TIP #280. Make actual argument location available to eval'd script
	 */

	TclArgumentGet(interp, objv[0], &invoker, &word);
	objPtr = objv[0];

    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc, objv);
    }

    TclNRAddCallback(interp, Uplevel_Callback, savedVarFramePtr, NULL, NULL,
	    NULL);
    return TclNREvalObjEx(interp, objPtr, 0, invoker, word);



}

/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --
 *








|



















<










|


>
>
>








960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986

987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009

    }
    objc -= result + 1;
    if (objc == 0) {
	goto uplevelSyntax;
    }
    objv += result + 1;

  havelevel:

    /*
     * Modify the interpreter state to execute in the given frame.
     */

    savedVarFramePtr = iPtr->varFramePtr;
    iPtr->varFramePtr = framePtr;

    /*
     * Execute the residual arguments as a command.
     */

    if (objc == 1) {
	/*
	 * TIP #280. Make actual argument location available to eval'd script
	 */

	TclArgumentGet(interp, objv[0], &invoker, &word);
	objPtr = objv[0];

    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

	objPtr = Tcl_ConcatObj(objc, objv);
    }

    TclNRAddCallback(interp, TclUplevelCallback, savedVarFramePtr, NULL, NULL,
	    NULL);
    return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
  uplevelSyntax:
    Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?");
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFindProc --
 *
︙︙
This page was generated in about 0.03s by Fossil 2.26 [1205ec86cb] 2025-04-30 16:57:32