From 345dcdfb8ad2fa31e53650c111342f7888d8cb8a Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 5 Dec 2023 15:48:03 +0000 Subject: Bytecode implementation --- generic/tclBasic.c | 2 +- generic/tclCompCmds.c | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 7 +++++ generic/tclCompile.h | 4 +++ generic/tclExecute.c | 71 ++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 1 + generic/tclVar.c | 6 ++-- 7 files changed, 165 insertions(+), 4 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index eab810d..f33469b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -316,7 +316,7 @@ static const CmdInfo builtInCmds[] = { {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, - {"const", Tcl_ConstObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"const", Tcl_ConstObjCmd, TclCompileConstCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index f86de84..2536ba7 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -919,6 +919,84 @@ TclCompileConcatCmd( /* *---------------------------------------------------------------------- * + * TclCompileConstCmd -- + * + * Procedure called to compile the "const" 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 "const" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileConstCmd( + Tcl_Interp *interp, /* The interpreter. */ + 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_Token *varTokenPtr, *valueTokenPtr; + int isScalar, localIndex; + + /* + * Need exactly two arguments. + */ + if (parsePtr->numWords != 3) { + return TCL_ERROR; + } + + /* + * Decide if we can use a frame slot for the var/array name or if we need + * to emit code to compute and push the name at runtime. We use a frame + * slot (entry in the array of local vars) if we are compiling a procedure + * body and if the name is simple text that does not include namespace + * qualifiers. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &isScalar, 1); + + /* + * If the user specified an array element, we don't bother handling + * that. + */ + if (!isScalar) { + return TCL_ERROR; + } + + /* + * We are doing an assignment to set the value of the constant. This will + * need to be extended to push a value for each argument. + */ + + valueTokenPtr = TokenAfter(varTokenPtr); + CompileWord(envPtr, valueTokenPtr, interp, 2); + + if (localIndex < 0) { + TclEmitOpcode(INST_CONST_STK, envPtr); + } else { + TclEmitInstInt4(INST_CONST_IMM, localIndex, envPtr); + } + + /* + * The const command's result is an empty string. + */ + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index e93fd4a..e321fc7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -665,6 +665,13 @@ InstructionDesc const tclInstructionTable[] = { * set in flags. */ + {"constImm", 5, -1, 1, {OPERAND_LVT4}}, + /* Create constant. Index into LVT is immediate, value is on stack. + * Stack: ... value => ... */ + {"constStk", 1, -2, 0, {OPERAND_NONE}}, + /* Create constant. Variable name and value on stack. + * Stack: ... varName value => ... */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 161ea62..560d144 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -837,6 +837,10 @@ enum TclInstruction { INST_LREPLACE4, + /* TIP 667: const */ + INST_CONST_IMM, + INST_CONST_STK, + /* The last opcode */ LAST_INST_OPCODE }; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8149532..8cce3ba 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3926,6 +3926,77 @@ TEBCresume( /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- + * Start of INST_CONST instructions. + */ + { + const char *msgPart; + + case INST_CONST_IMM: + opnd = TclGetUInt4AtPtr(pc+1); + pcAdjustment = 5; + cleanup = 1; + part1Ptr = NULL; + objPtr = OBJ_AT_TOS; + TRACE(("%u "\"%.30s\" => \n", opnd, O2S(objPtr))); + varPtr = LOCAL(opnd); + arrayPtr = NULL; + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + goto doConst; + case INST_CONST_STK: + opnd = -1; + pcAdjustment = 1; + cleanup = 2; + part1Ptr = OBJ_UNDER_TOS; + objPtr = OBJ_AT_TOS; + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr))); + varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, + /*createPart1*/1, /*createPart2*/0, &arrayPtr); + doConst: + if (TclIsVarConstant(varPtr)) { + TRACE_APPEND(("\n")); + NEXT_INST_V(pcAdjustment, cleanup, 0); + } + if (TclIsVarArray(varPtr)) { + msgPart = "variable is array"; + goto constError; + } else if (TclIsVarArrayElement(varPtr)) { + msgPart = "name refers to an element in an array"; + goto constError; + } else if (!TclIsVarUndefined(varPtr)) { + msgPart = "variable already exists"; + goto constError; + } + if (TclIsVarDirectModifyable(varPtr)) { + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + } else { + Tcl_Obj *resPtr; + + DECACHE_STACK_INFO(); + resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, NULL, + objPtr, TCL_LEAVE_ERR_MSG, opnd); + CACHE_STACK_INFO(); + if (resPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; + } + } + TclSetVarConstant(varPtr); + TRACE_APPEND(("\n")); + NEXT_INST_V(pcAdjustment, cleanup, 0); + + constError: + TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); + TRACE_ERROR(interp); + goto gotError; + } + + /* + * End of INST_CONST instructions. + * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index e9d3006..a9dcb01 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3774,6 +3774,7 @@ MODULE_SCOPE CompileProc TclCompileCatchCmd; MODULE_SCOPE CompileProc TclCompileClockClicksCmd; MODULE_SCOPE CompileProc TclCompileClockReadingCmd; MODULE_SCOPE CompileProc TclCompileConcatCmd; +MODULE_SCOPE CompileProc TclCompileConstCmd; MODULE_SCOPE CompileProc TclCompileContinueCmd; MODULE_SCOPE CompileProc TclCompileDictAppendCmd; MODULE_SCOPE CompileProc TclCompileDictCreateCmd; diff --git a/generic/tclVar.c b/generic/tclVar.c index de7e374..d0523c4 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4878,7 +4878,7 @@ Tcl_ConstObjCmd( "const", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (TclIsVarArray(varPtr)) { TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VAR", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); return TCL_ERROR; } if (TclIsVarArrayElement(varPtr)) { @@ -4886,7 +4886,7 @@ Tcl_ConstObjCmd( CleanupVar(varPtr, arrayPtr); } TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAYELEMENT, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); return TCL_ERROR; } @@ -4898,7 +4898,7 @@ Tcl_ConstObjCmd( return TCL_OK; } TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", EXISTS, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VAR", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); return TCL_ERROR; } -- cgit v0.12