diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclBasic.c | 89 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 60 | ||||
| -rw-r--r-- | generic/tclCompile.h | 15 | ||||
| -rw-r--r-- | generic/tclMathOp.c | 5 | ||||
| -rw-r--r-- | tests/mathop.test | 10 |
6 files changed, 122 insertions, 64 deletions
@@ -1,5 +1,12 @@ 2006-12-08 Don Porter <dgp@users.sourceforge.net> + * generic/tclBasic.c: Another step down the path of re-using + * generic/tclCompExpr.c: TclExecuteByteCode to implement the TIP 174 + * generic/tclCompile.h: commands instead of using a mass of code + * generic/tclMathOp.c: duplication. Now all operator commands that + * tests/mathop.test: demand exactly one operation are implemented + via TclSingleOpCmd and a call to TEBC. + * generic/tclCompExpr.c: Revised implementation of TclInvertOpCmd * generic/tclMathOp.c: to perform a bytecode compile / execute sequence. This demonstrates a path toward avoiding mountains of diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bef8f10..8c43737 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,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.227 2006/12/07 16:29:31 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.228 2006/12/08 20:48:08 dgp Exp $ */ #include "tclInt.h" @@ -53,6 +53,7 @@ static char * CallCommandTraces (Interp *iPtr, Command *cmdPtr, CONST char *oldName, CONST char* newName, int flags); static int CheckDoubleResult (Tcl_Interp *interp, double dResult); static void DeleteInterpProc (Tcl_Interp *interp); +static void DeleteOpCmdClientData(ClientData clientData); static void ProcessUnexpectedResult (Tcl_Interp *interp, int returnCode); static int OldMathFuncProc (ClientData clientData, Tcl_Interp *interp, @@ -270,31 +271,40 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { * TIP#174's math operators. */ -static const CmdInfo mathOpCmds[] = { - { "~", TclInvertOpCmd, TclCompileInvertOpCmd, 1 }, - { "!", TclNotOpCmd, TclCompileNotOpCmd, 1 }, - { "+", TclAddOpCmd, TclCompileAddOpCmd, 1 }, - { "*", TclMulOpCmd, TclCompileMulOpCmd, 1 }, - { "&", TclAndOpCmd, TclCompileAndOpCmd, 1 }, - { "|", TclOrOpCmd, TclCompileOrOpCmd, 1 }, - { "^", TclXorOpCmd, TclCompileXorOpCmd, 1 }, - { "**", TclPowOpCmd, TclCompilePowOpCmd, 1 }, - { "<<", TclLshiftOpCmd, TclCompileLshiftOpCmd, 1 }, - { ">>", TclRshiftOpCmd, TclCompileRshiftOpCmd, 1 }, - { "%", TclModOpCmd, TclCompileModOpCmd, 1 }, - { "!=", TclNeqOpCmd, TclCompileNeqOpCmd, 1 }, - { "ne", TclStrneqOpCmd, TclCompileStrneqOpCmd, 1 }, - { "in", TclInOpCmd, TclCompileInOpCmd, 1 }, - { "ni", TclNiOpCmd, TclCompileNiOpCmd, 1 }, - { "-", TclMinusOpCmd, TclCompileMinusOpCmd, 1 }, - { "/", TclDivOpCmd, TclCompileDivOpCmd, 1 }, - { "<", TclLessOpCmd, TclCompileLessOpCmd, 1 }, - { "<=", TclLeqOpCmd, TclCompileLeqOpCmd, 1 }, - { ">", TclGreaterOpCmd, TclCompileGreaterOpCmd, 1 }, - { ">=", TclGeqOpCmd, TclCompileGeqOpCmd, 1 }, - { "==", TclEqOpCmd, TclCompileEqOpCmd, 1 }, - { "eq", TclStreqOpCmd, TclCompileStreqOpCmd, 1 }, - { NULL, NULL, NULL, 0 } +typedef struct { + const char *name; /* Name of object-based command. */ + Tcl_ObjCmdProc *objProc; /* Object-based function for command. */ + CompileProc *compileProc; /* Function called to compile command. */ + int numArgs; + const char *expected; /* For error message, what argument(s) + * were expected. */ +} OpCmdInfo; + +static const OpCmdInfo mathOpCmds[] = { + { "~", TclSingleOpCmd, TclCompileInvertOpCmd, 1, "integer" }, + { "!", TclSingleOpCmd, TclCompileNotOpCmd, 1, "boolean" }, + { "+", TclAddOpCmd, TclCompileAddOpCmd, 0, NULL }, + { "*", TclMulOpCmd, TclCompileMulOpCmd, 0, NULL }, + { "&", TclAndOpCmd, TclCompileAndOpCmd, 0, NULL }, + { "|", TclOrOpCmd, TclCompileOrOpCmd, 0, NULL }, + { "^", TclXorOpCmd, TclCompileXorOpCmd, 0, NULL }, + { "**", TclPowOpCmd, TclCompilePowOpCmd, 0, NULL }, + { "<<", TclSingleOpCmd, TclCompileLshiftOpCmd, 2, "integer shift" }, + { ">>", TclSingleOpCmd, TclCompileRshiftOpCmd, 2, "integer shift" }, + { "%", TclSingleOpCmd, TclCompileModOpCmd, 2, "integer integer" }, + { "!=", TclSingleOpCmd, TclCompileNeqOpCmd, 2, "value value"}, + { "ne", TclSingleOpCmd, TclCompileStrneqOpCmd, 2, "value value" }, + { "in", TclSingleOpCmd, TclCompileInOpCmd, 2, "value list"}, + { "ni", TclSingleOpCmd, TclCompileNiOpCmd, 2, "value list"}, + { "-", TclMinusOpCmd, TclCompileMinusOpCmd, 0, NULL }, + { "/", TclDivOpCmd, TclCompileDivOpCmd, 0, NULL }, + { "<", TclLessOpCmd, TclCompileLessOpCmd, 0, NULL }, + { "<=", TclLeqOpCmd, TclCompileLeqOpCmd, 0, NULL }, + { ">", TclGreaterOpCmd, TclCompileGreaterOpCmd, 0, NULL }, + { ">=", TclGeqOpCmd, TclCompileGeqOpCmd, 0, NULL }, + { "==", TclEqOpCmd, TclCompileEqOpCmd, 0, NULL }, + { "eq", TclStreqOpCmd, TclCompileStreqOpCmd, 0, NULL }, + { NULL, NULL, NULL, 0, NULL } }; /* @@ -322,6 +332,7 @@ Tcl_CreateInterp(void) Tcl_Interp *interp; Command *cmdPtr; const BuiltinFuncDef *builtinFuncPtr; + const OpCmdInfo *opcmdInfoPtr; const CmdInfo *cmdInfoPtr; const CmdInfo2 *cmdInfo2Ptr; Tcl_Namespace *mathfuncNSPtr, *mathopNSPtr; @@ -633,14 +644,20 @@ Tcl_CreateInterp(void) } (void) Tcl_Export(interp, mathopNSPtr, "*", 1); strcpy(mathFuncName, "::tcl::mathop::"); - for (cmdInfoPtr=mathOpCmds ; cmdInfoPtr->name!=NULL ; cmdInfoPtr++) { - strcpy(mathFuncName + MATH_OP_PREFIX_LEN, cmdInfoPtr->name); + for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++) { + TclOpCmdClientData *occdPtr + = (TclOpCmdClientData *) ckalloc(sizeof(TclOpCmdClientData)); + occdPtr->operator = opcmdInfoPtr->name; + occdPtr->numArgs = opcmdInfoPtr->numArgs; + occdPtr->expected = opcmdInfoPtr->expected; + strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name); cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName, - cmdInfoPtr->objProc, NULL, NULL); + opcmdInfoPtr->objProc, (ClientData) occdPtr, + DeleteOpCmdClientData); if (cmdPtr == NULL) { - Tcl_Panic("failed to create math operator %s", cmdInfoPtr->name); - } else if (cmdInfoPtr->compileProc != NULL) { - cmdPtr->compileProc = cmdInfoPtr->compileProc; + Tcl_Panic("failed to create math operator %s", opcmdInfoPtr->name); + } else if (opcmdInfoPtr->compileProc != NULL) { + cmdPtr->compileProc = opcmdInfoPtr->compileProc; } } @@ -717,6 +734,14 @@ Tcl_CreateInterp(void) return interp; } + +static void +DeleteOpCmdClientData( + ClientData clientData) +{ + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + ckfree((char *)occdPtr); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 146c3c4..195f67e 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.41 2006/12/08 18:08:33 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.42 2006/12/08 20:48:09 dgp Exp $ */ #include "tclInt.h" @@ -2584,38 +2584,23 @@ CompileExprTree( } } -int -TclInvertOpCmd( - ClientData clientData, +static int +OpCmd( Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) + OpNode *nodes, + Tcl_Obj * const litObjv[]) { CompileEnv compEnv; ByteCode *byteCodePtr; - OpNode nodes[2]; - int code, tmp = 1; - Tcl_Obj *byteCodeObj; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "number"); - return TCL_ERROR; - } + int code, tmp=1; + Tcl_Obj *byteCodeObj = Tcl_NewObj(); /* Note we are compiling an expression with literal arguments. * This means there can be no [info frame] calls when we execute * the resulting bytecode, so there's no need to tend to TIP 280 issues */ TclInitCompileEnv(interp, &compEnv, NULL, 0, NULL, 0); - - nodes[0].lexeme = START; - nodes[0].right = 1; - nodes[1].lexeme = BIT_NOT; - nodes[1].right = OT_LITERAL; - nodes[1].parent = 0; - - CompileExprTree(interp, nodes, objv+1, NULL, NULL, &tmp, &compEnv); + CompileExprTree(interp, nodes, litObjv, NULL, NULL, &tmp, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); - byteCodeObj = Tcl_NewObj(); Tcl_IncrRefCount(byteCodeObj); TclInitByteCodeObj(byteCodeObj, &compEnv); TclFreeCompileEnv(&compEnv); @@ -2624,6 +2609,35 @@ TclInvertOpCmd( Tcl_DecrRefCount(byteCodeObj); return code; } + +int +TclSingleOpCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; + unsigned char lexeme; + OpNode nodes[2]; + + if (objc != 1+occdPtr->numArgs) { + Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected); + return TCL_ERROR; + } + + ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL); + nodes[0].lexeme = START; + nodes[0].right = 1; + nodes[1].lexeme = lexeme; + nodes[1].left = OT_LITERAL; + nodes[1].right = OT_LITERAL; + nodes[1].parent = 0; + + return OpCmd(interp, nodes, objv+1); +} + + /* *---------------------------------------------------------------------- diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5dc9cd7..c864c3c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.63 2006/12/08 18:08:35 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.64 2006/12/08 20:48:09 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -746,6 +746,16 @@ typedef struct JumptableInfo { } JumptableInfo; MODULE_SCOPE AuxDataType tclJumptableInfoType; + +/* + * ClientData type used by the math operator commands. + */ +typedef struct { + const char *operator; + const char *expected; + int numArgs; +} TclOpCmdClientData; + /* *---------------------------------------------------------------- @@ -845,6 +855,9 @@ MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr, MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); +MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); diff --git a/generic/tclMathOp.c b/generic/tclMathOp.c index f146a39..0ef70a1 100644 --- a/generic/tclMathOp.c +++ b/generic/tclMathOp.c @@ -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: tclMathOp.c,v 1.6 2006/12/08 18:08:37 dgp Exp $ + * RCS: @(#) $Id: tclMathOp.c,v 1.7 2006/12/08 20:48:09 dgp Exp $ */ #include "tclInt.h" @@ -1047,7 +1047,7 @@ CompareNumbers( * *---------------------------------------------------------------------- */ -#if 0 + int TclInvertOpCmd( ClientData clientData, @@ -1108,7 +1108,6 @@ TclInvertOpCmd( } } } -#endif /* *---------------------------------------------------------------------- diff --git a/tests/mathop.test b/tests/mathop.test index 477120d..b7e886b 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -10,7 +10,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.6 2006/12/08 16:14:18 dgp Exp $ +# RCS: @(#) $Id: mathop.test,v 1.7 2006/12/08 20:48:09 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -306,10 +306,10 @@ namespace eval ::testmathop { } -returnCodes error -result {can't use non-numeric string as operand of "~"} test mathop-4.9 {compiled ~: errors} -body { ~ 0 0 - } -returnCodes error -result "wrong # args: should be \"~ number\"" + } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.10 {compiled ~: errors} -body { ~ - } -returnCodes error -result "wrong # args: should be \"~ number\"" + } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.11 {compiled ~: errors} -returnCodes error -body { ~ 0.0 } -result {can't use floating-point value as operand of "~"} @@ -329,10 +329,10 @@ namespace eval ::testmathop { } -returnCodes error -result {can't use non-numeric string as operand of "~"} test mathop-4.21 {interpreted ~: errors} -body { $op 0 0 - } -returnCodes error -result "wrong # args: should be \"~ number\"" + } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.22 {interpreted ~: errors} -body { $op - } -returnCodes error -result "wrong # args: should be \"~ number\"" + } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.23 {interpreted ~: errors} -returnCodes error -body { $op 0.0 } -result {can't use floating-point value as operand of "~"} |