diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 218 | ||||
| -rw-r--r-- | tests/mathop.test | 6 |
3 files changed, 115 insertions, 117 deletions
@@ -1,9 +1,15 @@ +2006-12-06 Don Porter <dgp@users.sourceforge.net> + + * generic/tclCompCmds.c: Revised and consolidated into utility + * tests/mathop.c: routines some of routines that compile + the new TIP 174 commands. This corrects some known bugs. More to come. + 2006-12-06 Kevin Kenny <kennykb@acm.org> * tests/expr.test (expr-47.12): Improved error reporting in hopes of having more information to pursue [Bug 1609936]. -2006-11-28 Andreas Kupries <andreask@activestate.com> +2006-12-05 Andreas Kupries <andreask@activestate.com> TIP#291 IMPLEMENTATION diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 02bf071..c12e8b3 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.93 2006/11/28 22:20:28 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.94 2006/12/06 18:05:26 dgp Exp $ */ #include "tclInt.h" @@ -135,6 +135,12 @@ static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line); +static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, CONST char *identity, + unsigned char instruction, CompileEnv *envPtr); +static int CompileUnaryOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, unsigned char instruction, + CompileEnv *envPtr); /* * Flags bits used by PushVarName. @@ -4581,25 +4587,26 @@ PushVarName( /* *---------------------------------------------------------------------- * - * TclCompileInvertOpCmd -- + * CompileUnaryOpCmd -- * - * Procedure called to compile the "::tcl::mathop::~" command. + * Utility routine to compile the unary operator commands. * * 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 "::tcl::mathop::~" + * Instructions are added to envPtr to execute the compiled * command at runtime. * *---------------------------------------------------------------------- */ -int -TclCompileInvertOpCmd( +static int +CompileUnaryOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + unsigned char instruction, CompileEnv *envPtr) { Tcl_Token *tokenPtr; @@ -4610,50 +4617,103 @@ TclCompileInvertOpCmd( } tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode(INST_BITNOT, envPtr); + TclEmitOpcode(instruction, envPtr); return TCL_OK; } -int -TclCompileNotOpCmd( +/* + *---------------------------------------------------------------------- + * + * CompileAssociativeBinaryOpCmd -- + * + * Utility routine to compile the binary operator commands that + * accept an arbitrary number of arguments, and that are associative + * operations. Because of the associativity, we may combine operations + * from right to left, saving us any effort of re-ordering the arguments + * on the stack after substitutions are completed. + * + * 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 compiled + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +static int +CompileAssociativeBinaryOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, + CONST char *identity, + unsigned char instruction, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; + Tcl_Token *tokenPtr = parsePtr->tokenPtr; DefineLineInformation; /* TIP #280 */ + int words; - if (parsePtr->numWords != 2) { - return TCL_ERROR; + if (parsePtr->numWords == 1) { + PushLiteral(envPtr, identity, -1); + return TCL_OK; + } + for (words=1 ; words<parsePtr->numWords ; words++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, words); + } + while (--words > 1) { + TclEmitOpcode(instruction, envPtr); } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp, 1); - TclEmitOpcode(INST_LNOT, envPtr); return TCL_OK; } +/* + *---------------------------------------------------------------------- + * + * TclCompile*OpCmd -- + * + * Procedures called to compile the corresponding + * "::tcl::mathop::*" commands. + * + * 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 compiled + * command at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileInvertOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr); +} + +int +TclCompileNotOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr); +} + int TclCompileAddOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "0", 1); - return TCL_OK; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp,1); - for (words=2 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp,words); - TclEmitOpcode(INST_ADD, envPtr); - } - return TCL_OK; + return CompileAssociativeBinaryOpCmd(interp, parsePtr, + "0", INST_ADD, envPtr); } int @@ -4662,22 +4722,8 @@ TclCompileMulOpCmd( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "1", 1); - return TCL_OK; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp,1); - for (words=2 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp,words); - TclEmitOpcode(INST_MULT, envPtr); - } - return TCL_OK; + return CompileAssociativeBinaryOpCmd(interp, parsePtr, + "1", INST_MULT, envPtr); } int @@ -4686,22 +4732,8 @@ TclCompileAndOpCmd( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "-1", 2); - return TCL_OK; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp,1); - for (words=2 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp,words); - TclEmitOpcode(INST_BITAND, envPtr); - } - return TCL_OK; + return CompileAssociativeBinaryOpCmd(interp, parsePtr, + "-1", INST_BITAND, envPtr); } int @@ -4710,22 +4742,8 @@ TclCompileOrOpCmd( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "0", 1); - return TCL_OK; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp,1); - for (words=2 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp,words); - TclEmitOpcode(INST_BITOR, envPtr); - } - return TCL_OK; + return CompileAssociativeBinaryOpCmd(interp, parsePtr, + "0", INST_BITOR, envPtr); } int @@ -4734,22 +4752,8 @@ TclCompileXorOpCmd( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "0", 1); - return TCL_OK; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp,1); - for (words=2 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp,words); - TclEmitOpcode(INST_BITXOR, envPtr); - } - return TCL_OK; + return CompileAssociativeBinaryOpCmd(interp, parsePtr, + "0", INST_BITXOR, envPtr); } int @@ -4758,24 +4762,12 @@ TclCompilePowOpCmd( Tcl_Parse *parsePtr, CompileEnv *envPtr) { - Tcl_Token *tokenPtr; - DefineLineInformation; /* TIP #280 */ - int words; - - if (parsePtr->numWords == 1) { - PushLiteral(envPtr, "1", 1); - return TCL_OK; - } - tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp,1); - for (words=2 ; words<parsePtr->numWords ; words++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp,words); - } - for (; words>2 ; words--) { - TclEmitOpcode(INST_EXPON, envPtr); - } - return TCL_OK; + /* + * The ** operator isn't associative, but the right to left + * calculation order of the called routine is correct + */ + return CompileAssociativeBinaryOpCmd(interp, parsePtr, + "1", INST_EXPON, envPtr); } int diff --git a/tests/mathop.test b/tests/mathop.test index 9ad66f6..4f10b48 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: mathop.test,v 1.1 2006/11/26 12:52:55 dkf Exp $ +# RCS: @(#) $Id: mathop.test,v 1.2 2006/12/06 18:05:27 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -57,7 +57,7 @@ namespace eval ::testmathop { list [catch { + [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x - } -result {1 expected 2} -constraints knownBug + } -result {1 expected 2} set op + test mathop-1.19 {interpreted +} { $op } 0 test mathop-1.20 {interpreted +} { $op 1 } 1 @@ -132,7 +132,7 @@ namespace eval ::testmathop { list [catch { * [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x - } -result {1 expected 2} -constraints knownBug + } -result {1 expected 2} set op * test mathop-2.19 {interpreted *} { $op } 1 test mathop-2.20 {interpreted *} { $op 2 } 2 |