diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 9 | ||||
| -rw-r--r-- | generic/tclCompile.c | 68 | ||||
| -rw-r--r-- | tests/compile.test | 15 | ||||
| -rw-r--r-- | tests/misc.test | 6 |
5 files changed, 76 insertions, 30 deletions
@@ -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"}] |