summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-09-22 22:23:36 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-09-22 22:23:36 (GMT)
commit4c8817bf9f61487faa3fd056e823b43f4b800b9d (patch)
tree3a14fa3054e75c417ce931e83b4cb2a8bd73ed74
parentc11c7cb17b6d56aa132b51fcb4b242fe7941d337 (diff)
downloadtcl-4c8817bf9f61487faa3fd056e823b43f4b800b9d.zip
tcl-4c8817bf9f61487faa3fd056e823b43f4b800b9d.tar.gz
tcl-4c8817bf9f61487faa3fd056e823b43f4b800b9d.tar.bz2
* generic/tclCmdMZ.c (TclProcessReturn): Support the -errorline
* generic/tclCompile.c (TclCompileScript): option to [return]. * tests/compile.test (16.23.*): Use that capability to defer reporting * tests/misc.test (1.2): of parse errors until runtime. Updated tests to reflect change. [Bug 1032805]
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclCmdMZ.c9
-rw-r--r--generic/tclCompile.c68
-rw-r--r--tests/compile.test15
-rw-r--r--tests/misc.test6
5 files changed, 76 insertions, 30 deletions
diff --git a/ChangeLog b/ChangeLog
index a6c805b..d5becb8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-09-22 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclCmdMZ.c (TclProcessReturn): Support the -errorline
+ * generic/tclCompile.c (TclCompileScript): option to [return].
+ * tests/compile.test (16.23.*): Use that capability to defer reporting
+ * tests/misc.test (1.2): of parse errors until runtime.
+ Updated tests to reflect change. [Bug 1032805]
+
2004-09-22 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c (INST_START_CMD):
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 9f41208..93eda56 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -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: tclCmdMZ.c,v 1.106 2004/09/17 22:59:14 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.107 2004/09/22 22:23:39 dgp Exp $
*/
#include "tclInt.h"
@@ -921,6 +921,13 @@ TclProcessReturn(interp, code, level, returnOpts)
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
}
+
+ valuePtr = NULL;
+ Tcl_DictObjGet(NULL, iPtr->returnOpts,
+ iPtr->returnErrorlineKey, &valuePtr);
+ if (valuePtr != NULL) {
+ Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
+ }
}
} else {
code = TCL_RETURN;
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 8682429..86602bd 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,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.c,v 1.72 2004/09/21 22:45:41 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.73 2004/09/22 22:23:39 dgp Exp $
*/
#include "tclInt.h"
@@ -948,8 +948,46 @@ TclCompileScript(interp, script, numBytes, envPtr)
gotParse = 0;
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) {
- code = TCL_ERROR;
- goto error;
+ /* Compile bytecodes to report the parse error at runtime */
+ Tcl_Obj *returnCmd = Tcl_NewStringObj(
+ "return -code 1 -level 0 -errorinfo", -1);
+ Tcl_Obj *errMsg = Tcl_GetObjResult(interp);
+ Tcl_Obj *errInfo = Tcl_DuplicateObj(errMsg);
+ char *cmdString;
+ int cmdLength;
+ Tcl_Parse subParse;
+ int errorLine = 1;
+
+ Tcl_IncrRefCount(returnCmd);
+ Tcl_IncrRefCount(errInfo);
+ Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1);
+ TclAppendLimitedToObj(errInfo, parse.commandStart,
+ /* Drop the command terminator (";" or "]") if appropriate */
+ (parse.term == parse.commandStart + parse.commandSize - 1) ?
+ parse.commandSize - 1 : parse.commandSize, 153, NULL);
+ Tcl_AppendToObj(errInfo, "\"", -1);
+
+ Tcl_ListObjAppendElement(NULL, returnCmd, errInfo);
+
+ for (p = script; p != parse.commandStart; p++) {
+ if (*p == '\n') {
+ errorLine++;
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, returnCmd,
+ Tcl_NewStringObj("-errorline", -1));
+ Tcl_ListObjAppendElement(NULL, returnCmd,
+ Tcl_NewIntObj(errorLine));
+
+ Tcl_ListObjAppendElement(NULL, returnCmd, errMsg);
+ Tcl_DecrRefCount(errInfo);
+
+ cmdString = Tcl_GetStringFromObj(returnCmd, &cmdLength);
+ Tcl_ParseCommand(interp, cmdString, cmdLength, 0, &subParse);
+ TclCompileReturnCmd(interp, &subParse, envPtr);
+ Tcl_DecrRefCount(returnCmd);
+ Tcl_FreeParse(&subParse);
+ return TCL_OK;
}
gotParse = 1;
if (parse.numWords > 0) {
@@ -1224,26 +1262,6 @@ TclCompileScript(interp, script, numBytes, envPtr)
Tcl_DStringFree(&ds);
return TCL_OK;
- error:
- /*
- * Generate various pieces of error information, such as the line
- * number where the error occurred and information to add to the
- * errorInfo variable. Then free resources that had been allocated
- * to the command.
- */
-
- commandLength = parse.commandSize;
- if (parse.term == parse.commandStart + commandLength - 1) {
- /*
- * The terminator character (such as ; or ]) of the command where
- * the error occurred is the last character in the parsed command.
- * Reduce the length by one so that the error message doesn't
- * include the terminator character.
- */
-
- commandLength -= 1;
- }
-
log:
LogCompilationInfo(interp, script, parse.commandStart, commandLength);
if (gotParse) {
@@ -3339,7 +3357,7 @@ TclPrintInstruction(codePtr, pc)
|| (opCode == INST_JUMP_FALSE1))) {
fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
- fprintf(stdout, "%d", opnd);
+ fprintf(stdout, "%d ", opnd);
}
break;
case OPERAND_INT4:
@@ -3349,7 +3367,7 @@ TclPrintInstruction(codePtr, pc)
|| (opCode == INST_JUMP_FALSE4))) {
fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
} else {
- fprintf(stdout, "%d", opnd);
+ fprintf(stdout, "%d ", opnd);
}
break;
case OPERAND_UINT1:
diff --git a/tests/compile.test b/tests/compile.test
index c4eb685..6976b5b 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: compile.test,v 1.31 2004/08/02 15:33:36 dgp Exp $
+# RCS: @(#) $Id: compile.test,v 1.32 2004/09/22 22:23:40 dgp Exp $
package require tcltest 2
namespace import -force ::tcltest::*
@@ -570,6 +570,19 @@ test compile-16.22.$noComp {
rename ReturnResults {}
} -returnCodes ok -result [string trim [string repeat {x } 260]]
+test compile-16.23.$noComp {
+ Bug 1032805: defer parse error until run time
+} -body {
+ namespace eval x {
+ run {
+ proc if {a b} {uplevel 1 [list set $a $b]}
+ if 1 {syntax {}{}}
+ }
+ }
+} -cleanup {
+ namespace delete x
+} -returnCodes ok -result {syntax {}{}}
+
} ;# End of noComp loop
# cleanup
diff --git a/tests/misc.test b/tests/misc.test
index 3bacade..c82944b 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -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: misc.test,v 1.9 2004/07/04 18:02:42 dkf Exp $
+# RCS: @(#) $Id: misc.test,v 1.10 2004/09/22 22:23:40 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -57,14 +57,14 @@ test misc-1.2 {error in variable ref. in command in array reference} {
} [subst -novariables -nocommands {1
missing close-brace for variable name
missing close-brace for variable name
- while compiling
+ while executing
"set tst $a([winfo name $\{zz)
# this is a bogus comment
# this is a bogus comment
# this is a bogus comment
# this is a bogus comment
# this is a ..."
- (compiling body of proc "tstProc", line 4)
+ (procedure "tstProc" line 4)
invoked from within
"tstProc"}]