diff options
| author | dgp <dgp@users.sourceforge.net> | 2008-03-07 20:26:21 (GMT) |
|---|---|---|
| committer | dgp <dgp@users.sourceforge.net> | 2008-03-07 20:26:21 (GMT) |
| commit | ba2f16e25ec3ec55db446f05f90ecca28cc7cff8 (patch) | |
| tree | 6383517f43bf7bab71c1a1354a2595615d61333a | |
| parent | cd803d5fed6b3b5bbcf7198c48a646a464ffa12b (diff) | |
| download | tcl-ba2f16e25ec3ec55db446f05f90ecca28cc7cff8.zip tcl-ba2f16e25ec3ec55db446f05f90ecca28cc7cff8.tar.gz tcl-ba2f16e25ec3ec55db446f05f90ecca28cc7cff8.tar.bz2 | |
* generic/tclTest.c: Backport the [testexprlongobj] testing command.
| -rw-r--r-- | ChangeLog | 2 | ||||
| -rw-r--r-- | generic/tclTest.c | 49 | ||||
| -rw-r--r-- | tests/execute.test | 4 |
3 files changed, 53 insertions, 2 deletions
@@ -1,5 +1,7 @@ 2008-03-07 Don Porter <dgp@users.sourceforge.net> + * generic/tclTest.c: Backport the [testexprlongobj] testing command. + * tests/execute.test (execute-6.8): Added tests checking that bytecode is invalidates in the right situations. diff --git a/generic/tclTest.c b/generic/tclTest.c index 433444b..2b9bab0 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.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: tclTest.c,v 1.62.2.14 2007/06/27 17:29:23 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.62.2.15 2008/03/07 20:26:22 dgp Exp $ */ #define TCL_TEST @@ -240,6 +240,9 @@ static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); +static int TestexprlongobjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -613,6 +616,8 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testexprlongobj", TestexprlongobjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, @@ -2262,6 +2267,48 @@ TestexprlongCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestexprlongobjCmd -- + * + * This procedure verifies that Tcl_ExprLongObj does not modify the + * interpreter result if there is no error. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprlongobjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST *objv; /* Argument objects. */ +{ + long exprResult; + char buf[4 + TCL_INTEGER_SPACE]; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "expression"); + return TCL_ERROR; + } + Tcl_SetResult(interp, "This is a result", TCL_STATIC); + result = Tcl_ExprLongObj(interp, objv[1], &exprResult); + if (result != TCL_OK) { + return result; + } + sprintf(buf, ": %ld", exprResult); + Tcl_AppendResult(interp, buf, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestexprstringCmd -- * * This procedure tests the basic operation of Tcl_ExprString. diff --git a/tests/execute.test b/tests/execute.test index c7bd2fd..47ac562 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -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: execute.test,v 1.13.2.3 2008/03/07 19:10:03 dgp Exp $ +# RCS: @(#) $Id: execute.test,v 1.13.2.4 2008/03/07 20:26:22 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -35,6 +35,8 @@ catch {unset msg} ::tcltest::testConstraint longIs32bit \ [expr {int(0x80000000) < 0}] +::tcltest::testConstraint testexprlongobj \ + [llength [info commands testexprlongobj]] # Tests for the omnibus TclExecuteByteCode function: |