summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2008-03-07 20:26:21 (GMT)
committerdgp <dgp@users.sourceforge.net>2008-03-07 20:26:21 (GMT)
commitba2f16e25ec3ec55db446f05f90ecca28cc7cff8 (patch)
tree6383517f43bf7bab71c1a1354a2595615d61333a
parentcd803d5fed6b3b5bbcf7198c48a646a464ffa12b (diff)
downloadtcl-ba2f16e25ec3ec55db446f05f90ecca28cc7cff8.zip
tcl-ba2f16e25ec3ec55db446f05f90ecca28cc7cff8.tar.gz
tcl-ba2f16e25ec3ec55db446f05f90ecca28cc7cff8.tar.bz2
* generic/tclTest.c: Backport the [testexprlongobj] testing command.
-rw-r--r--ChangeLog2
-rw-r--r--generic/tclTest.c49
-rw-r--r--tests/execute.test4
3 files changed, 53 insertions, 2 deletions
diff --git a/ChangeLog b/ChangeLog
index f4dbb91..565c679 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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: