diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclCompCmdsSZ.c | 112 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 |
3 files changed, 117 insertions, 4 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b9282ae..148baa4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.448 2010/03/05 14:34:03 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.449 2010/03/19 11:54:06 dkf Exp $ */ #include "tclInt.h" @@ -238,7 +238,7 @@ static const CmdInfo builtInCmds[] = { {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1}, {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1}, {"tailcall", NULL, NULL, TclNRTailcallObjCmd, 1}, - {"throw", Tcl_ThrowObjCmd, NULL, NULL, 1}, + {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1}, {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1}, {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1}, diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 25ff92a..f6f8efb 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.4 2010/03/18 14:35:04 dkf Exp $ + * RCS: @(#) $Id: tclCompCmdsSZ.c,v 1.5 2010/03/19 11:54:07 dkf Exp $ */ #include "tclInt.h" @@ -1789,6 +1789,116 @@ PrintJumptableInfo( /* *---------------------------------------------------------------------- * + * TclCompileThrowCmd -- + * + * Procedure called to compile the "throw" 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 "throw" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileThrowCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + int numWords = parsePtr->numWords; + Tcl_Token *codeToken, *msgToken; + Tcl_Obj *objPtr; + + if (numWords != 3) { + return TCL_ERROR; + } + codeToken = TokenAfter(parsePtr->tokenPtr); + msgToken = TokenAfter(codeToken); + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + if (TclWordKnownAtCompileTime(codeToken, objPtr)) { + Tcl_Obj *errPtr, *dictPtr; + const char *string; + int len; + + /* + * The code is known at compilation time. This allows us to issue a + * very efficient sequence of instructions. + */ + + if (Tcl_ListObjLength(interp, objPtr, &len) != TCL_OK) { + /* + * Must still do this; might generate an error when getting this + * "ignored" value prepared as an argument. + */ + + CompileWord(envPtr, msgToken, interp, 2); + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; + } + if (len == 0) { + /* + * Must still do this; might generate an error when getting this + * "ignored" value prepared as an argument. + */ + + CompileWord(envPtr, msgToken, interp, 2); + goto issueErrorForEmptyCode; + } + TclNewLiteralStringObj(errPtr, "-errorcode"); + TclNewObj(dictPtr); + Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr); + Tcl_IncrRefCount(dictPtr); + string = Tcl_GetStringFromObj(dictPtr, &len); + CompileWord(envPtr, msgToken, interp, 2); + PushLiteral(envPtr, string, len); + TclDecrRefCount(dictPtr); + OP44( RETURN_IMM, 1, 0); + } else { + /* + * When the code token is not known at compilation time, we need to do + * a little bit more work. The main tricky bit here is that the error + * code has to be a list (a [throw] restriction) so we must emit extra + * instructions to enforce that condition. + */ + + CompileWord(envPtr, codeToken, interp, 1); + PUSH( "-errorcode"); + CompileWord(envPtr, msgToken, interp, 2); + OP4( REVERSE, 3); + OP( DUP); + OP( LIST_LENGTH); + OP1( JUMP_FALSE1, 16); + OP4( LIST, 2); + OP44( RETURN_IMM, 1, 0); + + /* + * Generate an error for being an empty list. Can't leverage anything + * else to do this for us. + */ + + issueErrorForEmptyCode: + PUSH( "type must be non-empty list"); + PUSH( ""); + OP44( RETURN_IMM, 1, 0); + } + TclDecrRefCount(objPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileTryCmd -- * * Procedure called to compile the "try" command. diff --git a/generic/tclInt.h b/generic/tclInt.h index 4bdb3c7..9661894 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.464 2010/03/05 14:34:04 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.465 2010/03/19 11:54:07 dkf Exp $ */ #ifndef _TCLINT @@ -3481,6 +3481,9 @@ MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileThrowCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileTryCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); |