From 130082d57a8eecf64d27adcb53065841cffae765 Mon Sep 17 00:00:00 2001 From: andreas_kupries Date: Tue, 25 Aug 2009 21:03:25 +0000 Subject: * generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard, Tcl_EvalEx, TclEvalEx, TclAdvanceContinuations, TclNREvalObjEx): * generic/tclCmdMZ.c (Tcl_SwitchObjCmd, TclListLines): * generic/tclCompCmds.c (*): * generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv, TclFreeCompileEnv, TclCompileScript, TclCompileTokens): * generic/tclCompile.h (CompileEnv): * generic/tclInt.h (ContLineLoc, Interp): * generic/tclObj.c (ThreadSpecificData, ContLineLocFree, TclThreadFinalizeObjects, TclInitObjSubsystem, TclContinuationsEnter, TclContinuationsEnterDerived, TclContinuationsCopy, TclContinuationsGet, TclFreeObj): * generic/tclParse.c (TclSubstTokens, Tcl_SubstObj): * generic/tclProc.c (TclCreateProc): * generic/tclVar.c (TclPtrSetVar): * tests/info.test (info-30.0-24): Extended the parser, compiler, and execution engine with code and attendant data structures tracking the position of continuation lines which are not visible in the resulting script Tcl_Obj*'s, to properly account for them while counting lines for #280. --- ChangeLog | 24 +++ generic/tclBasic.c | 162 ++++++++++++++++++-- generic/tclCmdMZ.c | 27 +++- generic/tclCompCmds.c | 113 ++++++++------ generic/tclCompile.c | 156 +++++++++++++++++++- generic/tclCompile.h | 12 +- generic/tclInt.h | 57 ++++++- generic/tclObj.c | 400 ++++++++++++++++++++++++++++++++++++++++++++++++-- generic/tclParse.c | 131 ++++++++++++++++- generic/tclProc.c | 14 +- generic/tclVar.c | 5 +- tests/info.test | 297 +++++++++++++++++++++++++++++++++++-- 12 files changed, 1288 insertions(+), 110 deletions(-) diff --git a/ChangeLog b/ChangeLog index df090b8..2b3e396 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,27 @@ +2009-08-25 Andreas Kupries + + * generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard, + Tcl_EvalEx, TclEvalEx, TclAdvanceContinuations, TclNREvalObjEx): + * generic/tclCmdMZ.c (Tcl_SwitchObjCmd, TclListLines): + * generic/tclCompCmds.c (*): + * generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv, + TclFreeCompileEnv, TclCompileScript, TclCompileTokens): + * generic/tclCompile.h (CompileEnv): + * generic/tclInt.h (ContLineLoc, Interp): + * generic/tclObj.c (ThreadSpecificData, ContLineLocFree, + TclThreadFinalizeObjects, TclInitObjSubsystem, + TclContinuationsEnter, TclContinuationsEnterDerived, + TclContinuationsCopy, TclContinuationsGet, TclFreeObj): + * generic/tclParse.c (TclSubstTokens, Tcl_SubstObj): + * generic/tclProc.c (TclCreateProc): + * generic/tclVar.c (TclPtrSetVar): + * tests/info.test (info-30.0-24): + + Extended the parser, compiler, and execution engine with code and + attendant data structures tracking the position of continuation + lines which are not visible in the resulting script Tcl_Obj*'s, to + properly account for them while counting lines for #280. + 2009-08-24 Daniel Steffen * generic/tclInt.h: Annotate Tcl_Panic as noreturn for clang static diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b83afe5..d97194c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,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.401 2009/08/12 16:06:41 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.402 2009/08/25 21:03:25 andreas_kupries Exp $ */ #include "tclInt.h" @@ -522,6 +522,7 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); + iPtr->scriptCLLocPtr = NULL; iPtr->activeVarTracePtr = NULL; @@ -4767,7 +4768,8 @@ Tcl_EvalTokensStandard( int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { - return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1); + return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, + NULL, NULL); } /* @@ -4851,7 +4853,7 @@ Tcl_EvalEx( * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ { - return TclEvalEx(interp, script, numBytes, flags, 1); + return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); } int @@ -4865,7 +4867,24 @@ TclEvalEx( int flags, /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ - int line) /* The line the script starts on. */ + int line, /* The line the script starts on. */ + int* clNextOuter, /* Information about an outer context for */ + CONST char* outerScript) /* continuation line data. This is set only in + * EvalTokensStandard(), to properly handle + * [...]-nested commands. The 'outerScript' + * refers to the most-outer script containing the + * embedded command, which is refered to by + * 'script'. The 'clNextOuter' refers to the + * current entry in the table of continuation + * lines in this "master script", and the + * character offsets are relative to the + * 'outerScript' as well. + * + * If outerScript == script, then this call is + * for the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for places + * generating arguments for which this is true. + */ { Interp *iPtr = (Interp *) interp; const char *p, *next; @@ -4891,6 +4910,23 @@ TclEvalEx( int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int)); /* TIP #280 Structures for tracking of command * locations. */ + /* + * Pointer for the tracking of invisible continuation lines. Initialized + * only if the caller gave us a table of locations to track, via + * scriptCLLocPtr. It always refers to the table entry holding the + * location of the next invisible continuation line to look for, while + * parsing the script. + */ + + int* clNext = NULL; + + if (iPtr->scriptCLLocPtr) { + if (clNextOuter) { + clNext = clNextOuter; + } else { + clNext = &iPtr->scriptCLLocPtr->loc[0]; + } + } if (numBytes < 0) { numBytes = strlen(script); @@ -4916,12 +4952,12 @@ TclEvalEx( /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * - * We may cont. counting based on a specific context (CTX), or open a new - * context, either for a sourced script, or 'eval'. For sourced files we - * always have a path object, even if nothing was specified in the interp - * itself. That makes code using it simpler as NULL checks can be left - * out. Sourced file without path in the 'scriptFile' is possible during - * Tcl initialization. + * We may continue counting based on a specific context (CTX), or open a + * new context, either for a sourced script, or 'eval'. For sourced files + * we always have a path object, even if nothing was specified in the + * interp itself. That makes code using it simpler as NULL checks can be + * left out. Sourced file without path in the 'scriptFile' is possible + * during Tcl initialization. */ eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; @@ -4989,19 +5025,25 @@ TclEvalEx( /* * TIP #280 Track lines. The parser may have skipped text till it * found the command we are now at. We have to count the lines in this - * block. + * block, and do not forget invisible continuation lines. */ TclAdvanceLines(&line, p, parsePtr->commandStart); + TclAdvanceContinuations (&line, &clNext, + parsePtr->commandStart - outerScript); gotParse = 1; if (parsePtr->numWords > 0) { /* - * TIP #280. Track lines within the words of the current command. + * TIP #280. Track lines within the words of the current + * command. We use a separate pointer into the table of + * continuation line locations to not lose our position for the + * per-command parsing. */ int wordLine = line; const char *wordStart = parsePtr->commandStart; + int* wordCLNext = clNext; /* * Generate an array of objects for the words of the command. @@ -5033,6 +5075,8 @@ TclEvalEx( */ TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); + TclAdvanceContinuations (&wordLine, &wordCLNext, + tokenPtr->start - outerScript); wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) @@ -5043,7 +5087,8 @@ TclEvalEx( } code = TclSubstTokens(interp, tokenPtr+1, - tokenPtr->numComponents, NULL, wordLine); + tokenPtr->numComponents, NULL, wordLine, + wordCLNext, outerScript); iPtr->evalFlags = 0; @@ -5075,6 +5120,11 @@ TclEvalEx( expand[objectsUsed] = 0; objectsNeeded++; } + + if (wordCLNext) { + TclContinuationsEnterDerived (objv[objectsUsed], + wordStart - outerScript, wordCLNext); + } } /* for loop */ iPtr->cmdFramePtr = eeFramePtr; if (code != TCL_OK) { @@ -5302,6 +5352,53 @@ TclAdvanceLines( /* *---------------------------------------------------------------------- + * + * TclAdvanceContinuations -- + * + * This procedure is a helper which counts the number of continuation + * lines (CL) in a block of text using a table of CL locations and + * advances an external counter, and the pointer into the table. + * + * Results: + * None. + * + * Side effects: + * The specified counter is advanced per the number of continuation lines + * found. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclAdvanceContinuations (line,clNextPtrPtr,loc) + int* line; + int** clNextPtrPtr; + int loc; +{ + /* + * Track the invisible continuation lines embedded in a script, if + * any. Here they are just spaces (already). They were removed by + * EvalTokensStandard() via Tcl_UtfBackslash(). + * + * *clNextPtrPtr <=> We have continuation lines to track. + * **clNextPtrPtr >= 0 <=> We are not beyond the last possible location. + * loc >= **clNextPtrPtr <=> We stepped beyond the current cont. line. + */ + + while (*clNextPtrPtr && (**clNextPtrPtr >= 0) && (loc >= **clNextPtrPtr)) { + /* + * We just stepped over an invisible continuation line. Adjust the + * line counter and step to the table entry holding the location of + * the next continuation line to track. + */ + (*line) ++; + (*clNextPtrPtr) ++; + } +} + +/* + *---------------------------------------------------------------------- * Note: The whole data structure access for argument location tracking is * hidden behind these three functions. The only parts open are the lineLAPtr * field in the Interp structure. The CFWord definition is internal to here. @@ -5919,6 +6016,33 @@ TclNREvalObjEx( const char *script; int numSrcBytes; + /* + * Now we check if we have data about invisible continuation lines for + * the script, and make it available to the direct script parser and + * evaluator we are about to call, if so. + * + * It may be possible that the script Tcl_Obj* can be free'd while the + * evaluator is using it, leading to the release of the associated + * ContLineLoc structure as well. To ensure that the latter doesn't + * happen we set a lock on it. We release this lock later in this + * function, after the evaluator is done. The relevant "lineCLPtr" + * hashtable is managed in the file "tclObj.c". + * + * Another important action is to save (and later restore) the + * continuation line information of the caller, in case we are + * executing nested commands in the eval/direct path. + */ + + ContLineLoc* saveCLLocPtr = iPtr->scriptCLLocPtr; + ContLineLoc* clLocPtr = TclContinuationsGet (objPtr); + + if (clLocPtr) { + iPtr->scriptCLLocPtr = clLocPtr; + Tcl_Preserve (iPtr->scriptCLLocPtr); + } else { + iPtr->scriptCLLocPtr = NULL; + } + Tcl_IncrRefCount(objPtr); if (invoker == NULL) { /* @@ -5974,7 +6098,7 @@ TclNREvalObjEx( iPtr->evalFlags |= TCL_EVAL_CTX; result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word]); + ctxPtr->line[word], NULL, script); if (pc) { /* @@ -5985,6 +6109,16 @@ TclNREvalObjEx( } } TclStackFree(interp, ctxPtr); + + /* + * Now release the lock on the continuation line information, if + * any, and restore the caller's settings. + */ + + if (iPtr->scriptCLLocPtr) { + Tcl_Release (iPtr->scriptCLLocPtr); + } + iPtr->scriptCLLocPtr = saveCLLocPtr; } TclDecrRefCount(objPtr); return result; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 706b905..2cce7be 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.190 2009/08/20 10:55:51 dkf Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.191 2009/08/25 21:03:25 andreas_kupries Exp $ */ #include "tclInt.h" @@ -3853,7 +3853,7 @@ TclNRSwitchObjCmd( ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; - TclListLines(TclGetString(blist), bline, objc, ctxPtr->line); + TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { /* * This is either a dynamic code word, when all elements are @@ -3893,7 +3893,7 @@ TclNRSwitchObjCmd( Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr, INT2PTR(pc), (ClientData) pattern); - return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, j); + return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); } static int SwitchPostProc( @@ -4701,21 +4701,34 @@ TclNRWhileObjCmd( void TclListLines( - const char *listStr, /* Pointer to string with list structure. - * Assumed to be valid. Assumed to contain n - * elements. */ + Tcl_Obj* listObj, /* Pointer to obj holding a string with list + * structure. Assumed to be valid. Assumed to + * contain n elements. + */ int line, /* Line the list as a whole starts on. */ int n, /* #elements in lines */ - int *lines) /* Array of line numbers, to fill. */ + int *lines, /* Array of line numbers, to fill. */ + Tcl_Obj* const* elems) /* The list elems as Tcl_Obj*, in need of + * derived continuation data */ { + CONST char* listStr = Tcl_GetString (listObj); + CONST char* listHead = listStr; int i, length = strlen(listStr); const char *element = NULL, *next = NULL; + ContLineLoc* clLocPtr = TclContinuationsGet(listObj); + int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); for (i = 0; i < n; i++) { TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); TclAdvanceLines(&line, listStr, element); /* Leading whitespace */ + TclAdvanceContinuations (&line, &clNext, element - listHead); + if (elems && clNext) { + TclContinuationsEnterDerived (elems[i], + element - listHead, + clNext); + } lines[i] = line; length -= (next - listStr); TclAdvanceLines(&line, element, next); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 8403a98..5b5871f 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -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: tclCompCmds.c,v 1.152 2009/02/03 23:34:32 nijtmans Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.153 2009/08/25 21:03:25 andreas_kupries Exp $ */ #include "tclInt.h" @@ -32,6 +32,7 @@ (tokenPtr)[1].size), (envPtr)); \ } else { \ envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); \ } @@ -49,6 +50,10 @@ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ int eclIndex = mapPtr->nuloc - 1 +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc [eclIndex].line [(word)]; \ + envPtr->clNext = mapPtr->loc [eclIndex].next [(word)] + /* * Convenience macro for use when compiling bodies of commands. The ANSI C * "prototype" for this macro is: @@ -160,7 +165,8 @@ static void PrintJumptableInfo(ClientData clientData, static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr, int line); + int *simpleVarNamePtr, int *isScalarPtr, + int line, int* clNext); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); @@ -177,6 +183,11 @@ static void CompileReturnInternal(CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts); +#define PushVarNameWord(i,v,e,f,l,s,sc,word) \ + PushVarName (i,v,e,f,l,s,sc, \ + mapPtr->loc [eclIndex].line [(word)], \ + mapPtr->loc [eclIndex].next [(word)]) + /* * Flags bits used by PushVarName. */ @@ -266,9 +277,8 @@ TclCompileAppendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, - mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so @@ -462,7 +472,7 @@ TclCompileCatchCmd( * range so that errors in the substitution are not catched [Bug 219184] */ - envPtr->line = mapPtr->loc[eclIndex].line[1]; + SetLineInformation (1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); @@ -944,7 +954,7 @@ TclCompileDictForCmd( * Compile the loop body itself. It should be stack-neutral. */ - envPtr->line = mapPtr->loc[eclIndex].line[4]; + SetLineInformation (4); CompileBody(envPtr, bodyTokenPtr, interp); TclEmitOpcode( INST_POP, envPtr); @@ -1481,7 +1491,7 @@ TclCompileForCmd( * Inline compile the initial command. */ - envPtr->line = mapPtr->loc[eclIndex].line[1]; + SetLineInformation (1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -1504,7 +1514,7 @@ TclCompileForCmd( */ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); - envPtr->line = mapPtr->loc[eclIndex].line[4]; + SetLineInformation (4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); envPtr->currStackDepth = savedStackDepth + 1; @@ -1516,7 +1526,7 @@ TclCompileForCmd( envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); - envPtr->line = mapPtr->loc[eclIndex].line[3]; + SetLineInformation (3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); envPtr->currStackDepth = savedStackDepth + 1; @@ -1537,7 +1547,7 @@ TclCompileForCmd( testCodeOffset += 3; } - envPtr->line = mapPtr->loc[eclIndex].line[2]; + SetLineInformation (2); envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; @@ -1787,7 +1797,7 @@ TclCompileForeachCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { - envPtr->line = mapPtr->loc[eclIndex].line[i]; + SetLineInformation (i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { @@ -1819,7 +1829,7 @@ TclCompileForeachCmd( * Inline compile the loop body. */ - envPtr->line = mapPtr->loc[eclIndex].line[bodyIndex]; + SetLineInformation (bodyIndex); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -2158,7 +2168,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { - envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; + SetLineInformation (wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -2200,7 +2210,7 @@ TclCompileIfCmd( */ if (compileScripts) { - envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; + SetLineInformation (wordIdx); envPtr->currStackDepth = savedStackDepth; CompileBody(envPtr, tokenPtr, interp); } @@ -2288,7 +2298,7 @@ TclCompileIfCmd( * Compile the else command body. */ - envPtr->line = mapPtr->loc[eclIndex].line[wordIdx]; + SetLineInformation (wordIdx); CompileBody(envPtr, tokenPtr, interp); } @@ -2390,9 +2400,8 @@ TclCompileIncrCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, - &localIndex, &simpleVarName, &isScalar, - mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX, + &localIndex, &simpleVarName, &isScalar, 1); /* * If an increment is given, push it, but see first if it's a small @@ -2418,7 +2427,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { - envPtr->line = mapPtr->loc[eclIndex].line[2]; + SetLineInformation (2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ @@ -2533,9 +2542,8 @@ TclCompileLappendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, - mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); /* * If we are doing an assignment, push the new value. In the no values @@ -2640,8 +2648,8 @@ TclCompileLassignCmd( * Generate the next variable name. */ - PushVarName(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[idx+2]); + PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, + &simpleVarName, &isScalar, idx+2); /* * Emit instructions to get the idx'th item out of the list value on @@ -2977,9 +2985,8 @@ TclCompileLsetCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, - mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); /* * Push the "index" args and the new element value. @@ -3479,9 +3486,8 @@ TclCompileSetCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, varTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, - mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); /* * If we are doing an assignment, push the new value. @@ -3762,7 +3768,7 @@ TclCompileStringMatchCmd( } PushLiteral(envPtr, str, length); } else { - envPtr->line = mapPtr->loc[eclIndex].line[i+1+nocase]; + SetLineInformation (i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); @@ -3828,7 +3834,7 @@ TclCompileStringLenCmd( len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { - envPtr->line = mapPtr->loc[eclIndex].line[1]; + SetLineInformation (1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } @@ -3878,6 +3884,7 @@ TclCompileSwitchCmd( Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ int *bodyLines; /* Array of line numbers for body list * items. */ + int** bodyNext; int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ @@ -3896,6 +3903,7 @@ TclCompileSwitchCmd( int isListedArms = 0; int i, valueIndex; DefineLineInformation; /* TIP #280 */ + int* clNext = envPtr->clNext; /* * Only handle the following versions: @@ -4074,6 +4082,7 @@ TclCompileSwitchCmd( bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); bodyLines = (int *) ckalloc(sizeof(int) * numWords); + bodyNext = (int **) ckalloc(sizeof(int*) * numWords); /* * Locate the start of the arms within the overall word. @@ -4117,6 +4126,7 @@ TclCompileSwitchCmd( ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); + ckfree((char *) bodyNext); return TCL_ERROR; } @@ -4127,7 +4137,10 @@ TclCompileSwitchCmd( */ TclAdvanceLines(&bline, p, bodyTokenArray[i].start); + TclAdvanceContinuations (&bline, &clNext, + bodyTokenArray[i].start - envPtr->source); bodyLines[i] = bline; + bodyNext[i] = clNext; p = bodyTokenArray[i].start; while (isspace(UCHAR(*tokenStartPtr))) { @@ -4155,6 +4168,7 @@ TclCompileSwitchCmd( ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); + ckfree((char *) bodyNext); return TCL_ERROR; } @@ -4175,6 +4189,7 @@ TclCompileSwitchCmd( bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); bodyLines = (int *) ckalloc(sizeof(int) * numWords); + bodyNext = (int **) ckalloc(sizeof(int*) * numWords); bodyTokenArray = NULL; for (i=0 ; inumComponents != 1) { ckfree((char *) bodyToken); ckfree((char *) bodyLines); + ckfree((char *) bodyNext); return TCL_ERROR; } bodyToken[i] = tokenPtr+1; @@ -4196,6 +4212,7 @@ TclCompileSwitchCmd( */ bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; + bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; tokenPtr = TokenAfter(tokenPtr); } } @@ -4209,6 +4226,7 @@ TclCompileSwitchCmd( bodyToken[numWords-1]->start[0] == '-') { ckfree((char *) bodyToken); ckfree((char *) bodyLines); + ckfree((char *) bodyNext); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } @@ -4220,7 +4238,7 @@ TclCompileSwitchCmd( * First, we push the value we're matching against on the stack. */ - envPtr->line = mapPtr->loc[eclIndex].line[valueIndex]; + SetLineInformation (valueIndex); CompileTokens(envPtr, valueTokenPtr, interp); /* @@ -4342,6 +4360,7 @@ TclCompileSwitchCmd( */ envPtr->line = bodyLines[i+1]; /* TIP #280 */ + envPtr->clNext = bodyNext[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); /* @@ -4393,6 +4412,7 @@ TclCompileSwitchCmd( ckfree((char *) finalFixups); ckfree((char *) bodyToken); ckfree((char *) bodyLines); + ckfree((char *) bodyNext); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } @@ -4554,6 +4574,7 @@ TclCompileSwitchCmd( TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth + 1; envPtr->line = bodyLines[i+1]; /* TIP #280 */ + envPtr->clNext = bodyNext[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); if (!foundDefault) { @@ -4570,6 +4591,7 @@ TclCompileSwitchCmd( ckfree((char *) bodyToken); ckfree((char *) bodyLines); + ckfree((char *) bodyNext); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } @@ -4826,7 +4848,7 @@ TclCompileWhileCmd( * Compile the loop body. */ - envPtr->line = mapPtr->loc[eclIndex].line[2]; + SetLineInformation (2); bodyCodeOffset = ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -4846,7 +4868,7 @@ TclCompileWhileCmd( testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; - envPtr->line = mapPtr->loc[eclIndex].line[1]; + SetLineInformation (1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; @@ -4911,7 +4933,8 @@ PushVarName( int *localIndexPtr, /* Must not be NULL. */ int *simpleVarNamePtr, /* Must not be NULL. */ int *isScalarPtr, /* Must not be NULL. */ - int line) /* Line the token starts on. */ + int line, /* Line the token starts on. */ + int* clNext) /* Reference to offset of next hidden cont. line */ { register const char *p; const char *name, *elName; @@ -5094,6 +5117,7 @@ PushVarName( if (elName != NULL) { if (elNameChars) { envPtr->line = line; + envPtr->clNext = clNext; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { PushLiteral(envPtr, "", 0); @@ -5105,6 +5129,7 @@ PushVarName( */ envPtr->line = line; + envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } @@ -5881,9 +5906,8 @@ TclCompileUpvarCmd( localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarName(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, - mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); if((localIndex < 0) || !isScalar) { return TCL_ERROR; @@ -5974,9 +5998,8 @@ TclCompileNamespaceCmd( localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, 1); - PushVarName(interp, localTokenPtr, envPtr, 0, - &localIndex, &simpleVarName, &isScalar, - mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, localTokenPtr, envPtr, 0, + &localIndex, &simpleVarName, &isScalar, 1); if((localIndex < 0) || !isScalar) { return TCL_ERROR; @@ -6490,8 +6513,8 @@ TclCompileInfoExistsCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarName(interp, tokenPtr, envPtr, 0, &localIndex, - &simpleVarName, &isScalar, mapPtr->loc[eclIndex].line[1]); + PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, + &simpleVarName, &isScalar, 1); /* * Emit instruction to check the variable for existence. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6b8b7a5..a0ac9d3 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.170 2009/07/16 21:24:39 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.171 2009/08/25 21:03:25 andreas_kupries Exp $ */ #include "tclInt.h" @@ -431,7 +431,8 @@ static void PrintSourceToObj(Tcl_Obj *appendObj, */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int len, - int numWords, int line, int **lines); + int numWords, int line, int* clNext, int **lines, + CompileEnv* envPtr); /* * The structure below defines the bytecode Tcl object type by means of @@ -487,6 +488,7 @@ TclSetByteCodeFromAny( register int i; int length, result = TCL_OK; const char *stringPtr; + ContLineLoc* clLocPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { @@ -508,6 +510,25 @@ TclSetByteCodeFromAny( TclInitCompileEnv(interp, &compEnv, stringPtr, length, iPtr->invokeCmdFramePtr, iPtr->invokeWord); + /* + * Now we check if we have data about invisible continuation lines for the + * script, and make it available to the compile environment, if so. + * + * It is not clear if the script Tcl_Obj* can be free'd while the compiler + * is using it, leading to the release of the associated ContLineLoc + * structure as well. To ensure that the latter doesn't happen we set a + * lock on it. We release this lock in the function TclFreeCompileEnv (), + * found in this file. The "lineCLPtr" hashtable is managed in the file + * "tclObj.c". + */ + + clLocPtr = TclContinuationsGet (objPtr); + if (clLocPtr) { + compEnv.clLoc = clLocPtr; + compEnv.clNext = &compEnv.clLoc->loc[0]; + Tcl_Preserve (compEnv.clLoc); + } + TclCompileScript(interp, stringPtr, length, &compEnv); /* @@ -1015,6 +1036,15 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->start = envPtr->line; + /* + * Initialize the data about invisible continuation lines as empty, + * i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if + * such data is available. + */ + + envPtr->clLoc = NULL; + envPtr->clNext = NULL; + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; @@ -1069,6 +1099,16 @@ TclFreeCompileEnv( if (envPtr->extCmdMapPtr) { ckfree((char *) envPtr->extCmdMapPtr); } + + /* + * If we used data about invisible continuation lines, then now is the + * time to release on our hold on it. The lock was set in function + * TclSetByteCodeFromAny(), found in this file. + */ + + if (envPtr->clLoc) { + Tcl_Release (envPtr->clLoc); + } } /* @@ -1196,6 +1236,7 @@ TclCompileScript( /* TIP #280 */ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat, cmdLine; + int* clNext; Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); @@ -1221,6 +1262,7 @@ TclCompileScript( p = script; bytesLeft = numBytes; cmdLine = envPtr->line; + clNext = envPtr->clNext; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { /* @@ -1320,10 +1362,12 @@ TclCompileScript( */ TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); + TclAdvanceContinuations (&cmdLine, &clNext, + parsePtr->commandStart - envPtr->source); EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, parsePtr->tokenPtr, parsePtr->commandStart, parsePtr->commandSize, parsePtr->numWords, cmdLine, - &wlines); + clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; /* @@ -1336,6 +1380,7 @@ TclCompileScript( tokenPtr += (tokenPtr->numComponents + 1)) { envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * The word is not a simple string of characters. @@ -1498,6 +1543,12 @@ TclCompileScript( */ objIndex = TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); + + if (envPtr->clNext) { + TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr, + tokenPtr[1].start - envPtr->source, + eclPtr->loc [wlineat].next [wordIdx]); + } } TclEmitPush(objIndex, envPtr); } /* for loop */ @@ -1559,7 +1610,9 @@ TclCompileScript( */ ckfree((char *) eclPtr->loc[wlineat].line); + ckfree((char *) eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; } /* end if parsePtr->numWords > 0 */ /* @@ -1575,6 +1628,7 @@ TclCompileScript( */ TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); + TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source); Tcl_FreeParse(parsePtr); } while (bytesLeft > 0); @@ -1635,6 +1689,41 @@ TclCompileTokens( int numObjsToConcat, nameBytes, localVarName, localVar; int length, i; unsigned char *entryCodeNext = envPtr->codeNext; +#define NUM_STATIC_POS 20 + int isLiteral, maxNumCL, numCL; + int* clPosition; + + /* + * For the handling of continuation lines in literals we first check if + * this is actually a literal. For if not we can forego the additional + * processing. Otherwise we pre-allocate a small table to store the + * locations of all continuation lines we find in this literal, if + * any. The table is extended if needed. + * + * Note: Different to the equivalent code in function 'TclSubstTokens()' + * (see file "tclParse.c") we do not seem to need the 'adjust' + * variable. We also do not seem to need code which merges continuation + * line information of multiple words which concat'd at runtime. Either + * that or I have not managed to find a test case for these two + * possibilities yet. It might be a difference between compile- versus + * runtime processing. + */ + + numCL = 0; + maxNumCL = 0; + isLiteral = 1; + for (i=0 ; i < count; i++) { + if ((tokenPtr[i].type != TCL_TOKEN_TEXT) && + (tokenPtr[i].type != TCL_TOKEN_BS)) { + isLiteral = 0; + break; + } + } + + if (isLiteral) { + maxNumCL = NUM_STATIC_POS; + clPosition = (int*) ckalloc (maxNumCL*sizeof(int)); + } Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; @@ -1647,6 +1736,36 @@ TclCompileTokens( case TCL_TOKEN_BS: length = Tcl_UtfBackslash(tokenPtr->start, NULL, buffer); Tcl_DStringAppend(&textBuffer, buffer, length); + + /* + * If the backslash sequence we found is in a literal, and + * represented a continuation line, we compute and store its + * location (as char offset to the beginning of the _result_ + * script). We may have to extend the table of locations. + * + * Note that the continuation line information is relevant even if + * the word we are processing is not a literal, as it can affect + * nested commands. See the branch for TCL_TOKEN_COMMAND below, + * where the adjustment we are tracking here is taken into + * account. The good thing is that we do not need a table of + * everything, just the number of lines we have to add as + * correction. + */ + + if ((length == 1) && (buffer[0] == ' ') && + (tokenPtr->start[1] == '\n')) { + if (isLiteral) { + int clPos = Tcl_DStringLength (&textBuffer); + + if (numCL >= maxNumCL) { + maxNumCL *= 2; + clPosition = (int*) ckrealloc ((char*)clPosition, + maxNumCL*sizeof(int)); + } + clPosition[numCL] = clPos; + numCL ++; + } + } break; case TCL_TOKEN_COMMAND: @@ -1662,6 +1781,12 @@ TclCompileTokens( TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); + + if (numCL) { + TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, + numCL, clPosition); + } + numCL = 0; } TclCompileScript(interp, tokenPtr->start+1, @@ -1770,6 +1895,12 @@ TclCompileTokens( Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; + + if (numCL) { + TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, + numCL, clPosition); + } + numCL = 0; } /* @@ -1792,6 +1923,15 @@ TclCompileTokens( TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } Tcl_DStringFree(&textBuffer); + + /* + * Release the temp table we used to collect the locations of + * continuation lines, if any. + */ + + if (maxNumCL) { + ckfree ((char*) clPosition); + } } /* @@ -2461,11 +2601,14 @@ EnterCmdWordData( int len, int numWords, int line, - int **wlines) + int* clNext, + int **wlines, + CompileEnv* envPtr) { ECL *ePtr; const char *last; int wordIdx, wordLine, *wwlines; + int* wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* @@ -2485,17 +2628,22 @@ EnterCmdWordData( ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; ePtr->line = (int *) ckalloc(numWords * sizeof(int)); + ePtr->next = (int**) ckalloc (numWords * sizeof (int*)); ePtr->nline = numWords; wwlines = (int *) ckalloc(numWords * sizeof(int)); last = cmd; wordLine = line; + wordNext = clNext; for (wordIdx=0 ; wordIdxnumComponents + 1) { TclAdvanceLines(&wordLine, last, tokenPtr->start); + TclAdvanceContinuations (&wordLine, &wordNext, + tokenPtr->start - envPtr->source); wwlines[wordIdx] = (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1); ePtr->line[wordIdx] = wordLine; + ePtr->next[wordIdx] = wordNext; last = tokenPtr->start; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 75dc236..4d9dbd1 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -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: tclCompile.h,v 1.117 2009/07/14 16:34:08 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.118 2009/08/25 21:03:25 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION @@ -132,6 +132,9 @@ typedef struct ECL { int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ + int** next; /* Transient information used by the compiler + * for tracking of hidden continuation + * lines. */ } ECL; typedef struct ExtCmdLoc { @@ -309,6 +312,13 @@ typedef struct CompileEnv { * should be issued; they should never be * issued repeatedly, as that is significantly * inefficient. */ + ContLineLoc* clLoc; /* If not NULL, the table holding the + * locations of the invisible continuation + * lines in the input script, to adjust the + * line counter. */ + int* clNext; /* If not NULL, it refers to the next slot in + * clLoc to check for an invisible + * continuation line. */ } CompileEnv; /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 3501083..6443c6f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.436 2009/08/24 03:18:23 das Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.437 2009/08/25 21:03:25 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1196,6 +1196,36 @@ typedef struct CFWordBC { } CFWordBC; /* + * Structure to record the locations of invisible continuation lines in + * literal scripts, as character offset from the beginning of the script. Both + * compiler and direct evaluator use this information to adjust their line + * counters when tracking through the script, because when it is invoked the + * continuation line marker as a whole has been removed already, meaning that + * the \n which was part of it is gone as well, breaking regular line + * tracking. + * + * These structures are allocated and filled by both the function + * TclSubstTokens() in the file "tclParse.c" and its caller TclEvalEx() in the + * file "tclBasic.c", and stored in the thread-global hashtable "lineCLPtr" in + * file "tclObj.c". They are used by the functions TclSetByteCodeFromAny() and + * TclCompileScript(), both found in the file "tclCompile.c". Their memory is + * released by the function TclFreeObj(), in the file "tclObj.c", and also by + * the function TclThreadFinalizeObjects(), in the same file. + */ + +#define CLL_END (-1) + +typedef struct ContLineLoc { + int num; /* Number of entries in loc, not counting the final -1 + * marker entry */ + int loc[1]; /* Table of locations, as character offsets. The table + * is allocated as part of the structure, i.e. the loc + * array extends behind the nominal end of the + * structure. An entry containing the value -1 is put + * after the last location, as end-marker/sentinel. */ +} ContLineLoc; + +/* * The following macros define the allowed values for the type field of the * CmdFrame structure above. Some of the values occur only in the extended * location data referenced via the 'baseLocPtr'. @@ -1983,6 +2013,16 @@ typedef struct Interp { * invoking command. Alt view: An index to the * CmdFrame stack keyed by command argument * holders. */ + ContLineLoc* scriptCLLocPtr; + /* This table points to the location data for + * invisible continuation lines in the script, + * if any. This pointer is set by the function + * TclEvalObjEx() in file "tclBasic.c", and + * used by function ...() in the same file. + * It does for the eval/direct path of script + * execution what CompileEnv.clLoc does for + * the bytecode compiler. + */ /* * TIP #268. The currently active selection mode, i.e. the package require * preferences. @@ -2651,6 +2691,7 @@ typedef struct ForIterData { MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); +MODULE_SCOPE void TclAdvanceContinuations(int* line, int** next, int loc); MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, @@ -2678,11 +2719,16 @@ MODULE_SCOPE int TclClearRootEnsemble(ClientData data[], Tcl_Interp *interp, int result); MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); +MODULE_SCOPE ContLineLoc* TclContinuationsEnter(Tcl_Obj* objPtr, int num, int* loc); +MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext); +MODULE_SCOPE ContLineLoc* TclContinuationsGet(Tcl_Obj* objPtr); +MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr); MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); /* TIP #280 - Modified token based evulation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - int numBytes, int flags, int line); + int numBytes, int flags, int line, + int* clNextOuter, CONST char* outerScript); MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, @@ -2776,8 +2822,8 @@ MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ -MODULE_SCOPE void TclListLines(const char *listStr, int line, int n, - int *lines); +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, + int *lines, Tcl_Obj* const* elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE int TclLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, int symc, const char *symbols[], @@ -2903,7 +2949,8 @@ MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - int count, int *tokensLeftPtr, int line); + int count, int *tokensLeftPtr, int line, + int* clNextOuter, CONST char* outerScript); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp, diff --git a/generic/tclObj.c b/generic/tclObj.c index 8052028..0bdb371 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.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: tclObj.c,v 1.155 2009/08/12 16:06:44 dgp Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.156 2009/08/25 21:03:25 andreas_kupries Exp $ */ #include "tclInt.h" @@ -68,18 +68,45 @@ typedef struct ObjData { int line; /* Line number in the source file; used for * debugging. */ } ObjData; - +#endif /* TCL_MEM_DEBUG && TCL_THREADS */ + /* - * Thread local table that is used to check that a Tcl_Obj was not allocated - * by some other thread. + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. + * + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { + Tcl_HashTable* lineCLPtr; /* This table remembers for each Tcl_Obj + * generated by a call to the function + * EvalTokensStandard() from a literal text + * where bs+nl sequences occured in it, if + * any. I.e. this table keeps track of + * invisible/stripped continuation lines. Its + * keys are Tcl_Obj pointers, the values are + * ContLineLoc pointers. See the file + * tclCompile.h for the definition of this + * structure, and for references to all related + * places in the core. + */ +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + /* + * Thread local table that is used to check that a Tcl_Obj was not + * allocated by some other thread. + */ + Tcl_HashTable *objThreadMap; +#endif /* TCL_MEM_DEBUG && TCL_THREADS */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#endif /* TCL_MEM_DEBUG && TCL_THREADS */ + +static void ContLineLocFree (char* clientData); +static void TclThreadFinalizeObjects (ClientData clientData); +static ThreadSpecificData* TclGetTables (void); /* * Nested Tcl_Obj deletion management support @@ -428,7 +455,7 @@ TclFinalizeThreadObjects(void) #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TclGetTables(); Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; if (tablePtr != NULL) { @@ -486,6 +513,313 @@ TclFinalizeObjects(void) } /* + *---------------------------------------------------------------------- + * + * TclGetTables -- + * + * This procedure is a helper which returns the thread-specific + * hash-table used to track continuation line information associated with + * Tcl_Obj*, and the objThreadMap, etc. + * + * Results: + * A reference to the thread-data. + * + * Side effects: + * May allocate memory for the thread-data. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static ThreadSpecificData* +TclGetTables() +{ + /* + * Initialize the hashtable tracking invisible continuation lines. For + * the release we use a thread exit handler to ensure that this is done + * before TSD blocks are made invalid. The TclFinalizeObjects() which + * would be the natural place for this is invoked afterwards, meaning that + * we try to operate on a data structure already gone. + */ + + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (!tsdPtr->lineCLPtr) { + tsdPtr->lineCLPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); + Tcl_CreateThreadExitHandler (TclThreadFinalizeObjects,NULL); +#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) + tsdPtr->objThreadMap = NULL; +#endif /* TCL_MEM_DEBUG && TCL_THREADS */ + } + return tsdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsEnter -- + * + * This procedure is a helper which saves the continuation line + * information associated with a Tcl_Obj*. + * + * Results: + * A reference to the newly created continuation line location table. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +ContLineLoc* +TclContinuationsEnter(Tcl_Obj* objPtr, + int num, + int* loc) +{ + int newEntry; + ThreadSpecificData *tsdPtr = TclGetTables(); + Tcl_HashEntry* hPtr = + Tcl_CreateHashEntry (tsdPtr->lineCLPtr, (char*) objPtr, &newEntry); + + ContLineLoc* clLocPtr = + (ContLineLoc*) ckalloc (sizeof(ContLineLoc) + num*sizeof(int)); + + clLocPtr->num = num; + memcpy (&clLocPtr->loc, loc, num*sizeof(int)); + clLocPtr->loc[num] = CLL_END; /* Sentinel */ + Tcl_SetHashValue (hPtr, clLocPtr); + + return clLocPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsEnterDerived -- + * + * This procedure is a helper which computes the continuation line + * information associated with a Tcl_Obj* cut from the middle of a + * script. + * + * Results: + * None. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclContinuationsEnterDerived(Tcl_Obj* objPtr, int start, int* clNext) +{ + /* + * We have to handle invisible continuations lines here as well, despite + * the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If + * our script is the sole argument to an 'eval' command, for example, the + * scriptCLLocPtr we are using was generated by a previous call to TST, + * and while the words we have here may contain continuation lines they + * are invisible already, and the inner call to TST had no bs+nl sequences + * to trigger its code. + * + * Luckily for us, the table we have to create here for the current word + * has to be a slice of the table currently in use, with the locations + * suitably modified to be relative to the start of the word instead of + * relative to the script. + * + * That is what we are doing now. Determine the slice we need, and if not + * empty, wrap it into a new table, and save the result into our + * thread-global hashtable, as usual. + */ + + /* + * First compute the range of the word within the script. + */ + + int length, end, num; + int* wordCLLast = clNext; + + Tcl_GetStringFromObj(objPtr, &length); + /* Is there a better way which doesn't shimmer ? */ + + end = start + length; /* first char after the word */ + + /* + * Then compute the table slice covering the range of + * the word. + */ + + while (*wordCLLast >= 0 && *wordCLLast < end) { + wordCLLast++; + } + + /* + * And generate the table from the slice, if it was + * not empty. + */ + + num = wordCLLast - clNext; + if (num) { + int i; + ContLineLoc* clLocPtr = + TclContinuationsEnter(objPtr, num, clNext); + + /* + * Re-base the locations. + */ + + for (i=0;iloc[i] -= start; + + /* + * Continuation lines coming before the string and affecting us + * should not happen, due to the proper maintenance of clNext + * during compilation. + */ + + if (clLocPtr->loc[i] < 0) { + Tcl_Panic("Derived ICL data for object using offsets from before the script"); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsCopy -- + * + * This procedure is a helper which copies the continuation line + * information associated with a Tcl_Obj* to another Tcl_Obj*. + * It is assumed that both contain the same string/script. Use + * this when a script is duplicated because it was shared. + * + * Results: + * None. + * + * Side effects: + * Allocates memory for the table of continuation line locations. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclContinuationsCopy(Tcl_Obj* objPtr, Tcl_Obj* originObjPtr) +{ + ThreadSpecificData *tsdPtr = TclGetTables(); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) originObjPtr); + + if (hPtr) { + ContLineLoc* clLocPtr = (ContLineLoc*) Tcl_GetHashValue (hPtr); + + TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclContinuationsGet -- + * + * This procedure is a helper which retrieves the continuation line + * information associated with a Tcl_Obj*, if it has any. + * + * Results: + * A reference to the continuation line location table, or NULL + * if the Tcl_Obj* has no such information associated with it. + * + * Side effects: + * None. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +ContLineLoc* +TclContinuationsGet(Tcl_Obj* objPtr) +{ + ThreadSpecificData *tsdPtr = TclGetTables(); + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char*) objPtr); + + if (hPtr) { + return (ContLineLoc*) Tcl_GetHashValue (hPtr); + } else { + return NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclThreadFinalizeObjects -- + * + * This procedure is a helper which releases all continuation line + * information currently known. It is run as a thread exit handler. + * + * Results: + * None. + * + * Side effects: + * Releases memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static void +TclThreadFinalizeObjects (ClientData clientData) +{ + /* + * Release the hashtable tracking invisible continuation lines. + */ + + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + ThreadSpecificData *tsdPtr = TclGetTables(); + + for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + /* + * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because + * here we can be sure that the compiler will not hold references to + * the data in the hashtable, and using TEF might bork the + * finalization sequence. + */ + ContLineLocFree (Tcl_GetHashValue (hPtr)); + Tcl_DeleteHashEntry (hPtr); + } + Tcl_DeleteHashTable (tsdPtr->lineCLPtr); + tsdPtr->lineCLPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ContLineLocFree -- + * + * The freProc for continuation line location tables. + * + * Results: + * None. + * + * Side effects: + * Releases memory. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +static void +ContLineLocFree (char* clientData) +{ + ckfree (clientData); +} + +/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -677,7 +1011,7 @@ TclDbDumpActiveObjects( Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TclGetTables(); tablePtr = tsdPtr->objThreadMap; @@ -744,7 +1078,7 @@ TclDbInitNewObj( Tcl_HashTable *tablePtr; int isNew; ObjData *objData; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TclGetTables(); if (tsdPtr->objThreadMap == NULL) { tsdPtr->objThreadMap = (Tcl_HashTable *) @@ -1010,6 +1344,28 @@ TclFreeObj( } ObjDeletionUnlock(context); } + + /* + * We cannot use TclGetContinuationTable() here, because that may + * re-initialize the thread-data for calls coming after the + * finalization. We have to access it using the low-level call and then + * check for validity. This function can be called after + * TclFinalizeThreadData() has already killed the thread-global data + * structures. Performing TCL_TSD_INIT will leave us with an + * un-initialized memory block upon which we crash (if we where to access + * the uninitialized hashtable). + */ + + { + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); + if (tsdPtr->lineCLPtr) { + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); + if (hPtr) { + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); + } + } + } } #else /* TCL_MEM_DEBUG */ @@ -1075,6 +1431,28 @@ TclFreeObj( ObjDeletionUnlock(context); } } + + /* + * We cannot use TclGetContinuationTable() here, because that may + * re-initialize the thread-data for calls coming after the + * finalization. We have to access it using the low-level call and then + * check for validity. This function can be called after + * TclFinalizeThreadData() has already killed the thread-global data + * structures. Performing TCL_TSD_INIT will leave us with an + * un-initialized memory block upon which we crash (if we where to access + * the uninitialized hashtable). + */ + + { + ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); + if (tsdPtr->lineCLPtr) { + Tcl_HashEntry* hPtr = Tcl_FindHashEntry (tsdPtr->lineCLPtr, (char *) objPtr); + if (hPtr) { + Tcl_EventuallyFree (Tcl_GetHashValue (hPtr), ContLineLocFree); + Tcl_DeleteHashEntry (hPtr); + } + } + } } #endif @@ -3267,7 +3645,7 @@ Tcl_DbIncrRefCount( if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TclGetTables(); tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { @@ -3332,7 +3710,7 @@ Tcl_DbDecrRefCount( if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TclGetTables(); tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { @@ -3412,7 +3790,7 @@ Tcl_DbIsShared( if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TclGetTables(); tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); diff --git a/generic/tclParse.c b/generic/tclParse.c index db64728..69cc830 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1553,7 +1553,7 @@ Tcl_ParseVar( } code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, - NULL, 1); + NULL, 1, NULL, NULL); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; @@ -2062,7 +2062,7 @@ Tcl_SubstObj( endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokensLeft = parsePtr->numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, - &tokensLeft, 1); + &tokensLeft, 1, NULL, NULL); if (code == TCL_OK) { Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); @@ -2107,7 +2107,7 @@ Tcl_SubstObj( } code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, - &tokensLeft, 1); + &tokensLeft, 1, NULL, NULL); } } @@ -2145,10 +2145,31 @@ TclSubstTokens( int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ - int line) /* The line the script starts on. */ + int line, /* The line the script starts on. */ + int* clNextOuter, /* Information about an outer context for */ + CONST char* outerScript) /* continuation line data. This is set by + * EvalEx() to properly handle [...]-nested + * commands. The 'outerScript' refers to the + * most-outer script containing the embedded + * command, which is refered to by 'script'. The + * 'clNextOuter' refers to the current entry in + * the table of continuation lines in this + * "master script", and the character offsets are + * relative to the 'outerScript' as well. + * + * If outerScript == script, then this call is for + * words in the outer-most script/command. See + * Tcl_EvalEx() and TclEvalObjEx() for the places + * generating arguments for which this is true. + */ { Tcl_Obj *result; int code = TCL_OK; +#define NUM_STATIC_POS 20 + int isLiteral, maxNumCL, numCL, i, adjust; + int* clPosition; + Interp* iPtr = (Interp*) interp; + int inFile = iPtr->evalFlags & TCL_EVAL_FILE; /* * Each pass through this loop will substitute one token, and its @@ -2160,6 +2181,31 @@ TclSubstTokens( * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them. */ + /* + * For the handling of continuation lines in literals we first check if + * this is actually a literal. For if not we can forego the additional + * processing. Otherwise we pre-allocate a small table to store the + * locations of all continuation lines we find in this literal, if + * any. The table is extended if needed. + */ + + numCL = 0; + maxNumCL = 0; + isLiteral = 1; + for (i=0 ; i < count; i++) { + if ((tokenPtr[i].type != TCL_TOKEN_TEXT) && + (tokenPtr[i].type != TCL_TOKEN_BS)) { + isLiteral = 0; + break; + } + } + + if (isLiteral) { + maxNumCL = NUM_STATIC_POS; + clPosition = (int*) ckalloc (maxNumCL*sizeof(int)); + } + + adjust = 0; result = NULL; for (; count>0 && code==TCL_OK ; count--, tokenPtr++) { Tcl_Obj *appendObj = NULL; @@ -2177,17 +2223,66 @@ TclSubstTokens( appendByteLength = Tcl_UtfBackslash(tokenPtr->start, NULL, utfCharBytes); append = utfCharBytes; + + /* + * If the backslash sequence we found is in a literal, and + * represented a continuation line, we compute and store its + * location (as char offset to the beginning of the _result_ + * script). We may have to extend the table of locations. + * + * Note that the continuation line information is relevant even if + * the word we are processing is not a literal, as it can affect + * nested commands. See the branch for TCL_TOKEN_COMMAND below, + * where the adjustment we are tracking here is taken into + * account. The good thing is that we do not need a table of + * everything, just the number of lines we have to add as + * correction. + */ + + if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') && + (tokenPtr->start[1] == '\n')) { + if (isLiteral) { + int clPos; + if (result == 0) { + clPos = 0; + } else { + Tcl_GetStringFromObj(result, &clPos); + } + + if (numCL >= maxNumCL) { + maxNumCL *= 2; + clPosition = (int*) ckrealloc ((char*)clPosition, + maxNumCL*sizeof(int)); + } + clPosition[numCL] = clPos; + numCL ++; + } + adjust ++; + } break; case TCL_TOKEN_COMMAND: { - Interp *iPtr = (Interp *) interp; - /* TIP #280: Transfer line information to nested command */ iPtr->numLevels++; code = TclInterpReady(interp); if (code == TCL_OK) { + /* + * Test cases: info-30.{6,8,9} + */ + + int theline; + TclAdvanceContinuations (&line, &clNextOuter, + tokenPtr->start - outerScript); + theline = line + adjust; code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, - 0, line); + 0, theline, clNextOuter, outerScript); + /* + * Restore flag reset by nested eval for future bracketed + * commands and their cmdframe setup + */ + if (inFile) { + iPtr->evalFlags |= TCL_EVAL_FILE; + } } iPtr->numLevels--; TclResetCancellation(interp, 0); @@ -2205,7 +2300,7 @@ TclSubstTokens( */ code = TclSubstTokens(interp, tokenPtr+2, - tokenPtr->numComponents - 1, NULL, line); + tokenPtr->numComponents - 1, NULL, line, NULL, NULL); arrayIndex = Tcl_GetObjResult(interp); Tcl_IncrRefCount(arrayIndex); } @@ -2289,6 +2384,26 @@ TclSubstTokens( if (code != TCL_ERROR) { /* Keep error message in result! */ if (result != NULL) { Tcl_SetObjResult(interp, result); + /* + * If the code found continuation lines (which implies that this + * word is a literal), then we store the accumulated table of + * locations in the thread-global data structure for the bytecode + * compiler to find later, assuming that the literal is a script + * which will be compiled. + */ + + if (numCL) { + TclContinuationsEnter(result, numCL, clPosition); + } + + /* + * Release the temp table we used to collect the locations of + * continuation lines, if any. + */ + + if (maxNumCL) { + ckfree ((char*) clPosition); + } } else { Tcl_ResetResult(interp); } diff --git a/generic/tclProc.c b/generic/tclProc.c index 98784c3..12e19da 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -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: tclProc.c,v 1.173 2009/07/16 21:24:40 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.174 2009/08/25 21:03:25 andreas_kupries Exp $ */ #include "tclInt.h" @@ -440,8 +440,18 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + Tcl_Obj* sharedBodyPtr = bodyPtr; + bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); + + /* + * TIP #280. + * Ensure that the continuation line data for the original body is + * not lost and applies to the new body as well. + */ + + TclContinuationsCopy (bodyPtr, sharedBodyPtr); } /* @@ -2538,7 +2548,7 @@ SetLambdaFromAny( * location (line of 2nd list element). */ - TclListLines(name, contextPtr->line[1], 2, buf); + TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; diff --git a/generic/tclVar.c b/generic/tclVar.c index 52eaf9f..ebd9d96 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.181 2009/07/23 23:01:59 andreas_kupries Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.182 2009/08/25 21:03:25 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1876,6 +1876,9 @@ TclPtrSetVar( } else { if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + + TclContinuationsCopy (varPtr->value.objPtr, oldValuePtr); + TclDecrRefCount(oldValuePtr); oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ diff --git a/tests/info.test b/tests/info.test index 53a0e76..65d71bc 100644 --- a/tests/info.test +++ b/tests/info.test @@ -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: info.test,v 1.64 2009/07/14 16:34:09 andreas_kupries Exp $ +# RCS: @(#) $Id: info.test,v 1.65 2009/08/25 21:03:25 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -767,7 +767,7 @@ test info-22.8 {info frame, basic trace} -match glob -body { * {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest} * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} -## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 + test info-23.0.0 {eval'd info frame} {!singleTestInterp} { eval {info frame} } 8 @@ -806,7 +806,7 @@ test info-23.6 {eval'd info frame, trace} -match glob -body { } -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} * {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}} -## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 + # ------------------------------------------------------------------------- # Procedures defined in scripts which are arguments to control @@ -1011,20 +1011,20 @@ test info-25.1 {info frame, regular proc} { rename bar {} # ------------------------------------------------------------------------- - -test info-30.0 {bs+nl in literal words} knownBug { +# More info-30.x test cases at the end of the file. +test info-30.0 {bs+nl in literal words} { if {1} { set res \ - [reduce [info frame 0]] + [reduce [info frame 0]];#1018 } set res - # This is reporting line 3 instead of the correct 4 because the + # This was reporting line 3 instead of the correct 4 because the # bs+nl combination is subst by the parser before the 'if' - # command, and the the bcc sees the word. To fix record the - # offsets of all bs+nl sequences in literal words, then use the - # information in the bcc to bump line numbers when parsing over - # the location. Also affected: testcases 22.8 and 23.6. -} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest} + # command, and the bcc, see the word. Fixed by recording the + # offsets of all bs+nl sequences in literal words, then using the + # information in the bcc and other places to bump line numbers when + # parsing over the location. Also affected: testcases 22.8 and 23.6. +} {type source line 1018 file info.test cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- # See 24.0 - 24.5 for similar situations, using literal scripts. @@ -1436,6 +1436,279 @@ type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0 type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +# Additional tests for info-30.*, handling of continuation lines (bs+nl sequences). + +test info-30.1 {bs+nl in literal words, procedure body, compiled} { + proc abra {} { + if {1} \ + { + return \ + [reduce [info frame 0]];# line 1446 + } + } + set res [abra] + rename abra {} + set res +} {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0} + +test info-30.2 {bs+nl in literal words, namespace script} { + namespace eval xxx { + set res \ + [reduce [info frame 0]];# line 1457 + } + set res +} {type source line 1457 file info.test cmd {info frame 0} level 0} + +test info-30.3 {bs+nl in literal words, namespace multi-word script} { + namespace eval xxx set res \ + [list [reduce [info frame 0]]];# line 1464 + set res +} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.4 {bs+nl in literal words, eval script} { + eval { + set ::res \ + [reduce [info frame 0]];# line 1471 + } + set res +} {type source line 1471 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.5 {bs+nl in literal words, eval script, with nested words} { + eval { + if {1} \ + { + set ::res \ + [reduce [info frame 0]];# line 1481 + } + } + set res +} {type source line 1481 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.6 {bs+nl in computed word} { + set res "\ +[reduce [info frame 0]]";# line 1489 +} { type source line 1489 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.7 {bs+nl in computed word, in proc} { + proc abra {} { + return "\ +[reduce [info frame 0]]";# line 1495 + } + set res [abra] + rename abra {} + set res +} { type source line 1495 file info.test cmd {info frame 0} proc ::abra level 0} + +test info-30.8 {bs+nl in computed word, nested eval} { + eval { + set \ + res "\ +[reduce [info frame 0]]";# line 1506 +} +} { type source line 1506 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.9 {bs+nl in computed word, nested eval} { + eval { + set \ + res "\ +[reduce \ + [info frame 0]]";# line 1515 +} +} { type source line 1515 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.10 {bs+nl in computed word, key to array} { + set tmp([set \ + res "\ +[reduce \ + [info frame 0]]"]) x ; #1523 + unset tmp + set res +} { type source line 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.11 {bs+nl in subst arguments, no true counting} { + subst {[set \ + res "\ +[reduce \ + [info frame 0]]"]} +} { type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.12 {bs+nl in computed word, nested eval} { + eval { + set \ + res "\ +[set x {}] \ +[reduce \ + [info frame 0]]";# line 1541 +} +} { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.13 {bs+nl in literal words, uplevel script, with nested words} { + uplevel #0 { + if {1} \ + { + set ::res \ + [reduce [info frame 0]];# line 1550 + } + } + set res +} {type source line 1550 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.14 {bs+nl, literal word, uplevel through proc} { + proc abra {script} { + uplevel 1 $script + } + set res [abra { + return "\ +[reduce [info frame 0]]";# line 1562 + }] + rename abra {} + set res +} { type source line 1562 file info.test cmd {info frame 0} proc ::abra} + +test info-30.15 {bs+nl in literal words, nested proc body, compiled} { + proc a {} { + proc b {} { + if {1} \ + { + return \ + [reduce [info frame 0]];# line 1574 + } + } + } + a ; set res [b] + rename a {} + rename b {} + set res +} {type source line 1574 file info.test cmd {info frame 0} proc ::b level 0} + +test info-30.16 {bs+nl in multi-body switch, compiled} { + proc a {value} { + switch -regexp -- $value \ + ^key { info frame 0; # 1587 } \ + \t### { info frame 0; # 1588 } \ + {[0-9]*} { info frame 0; # 1589 } + } + set res {} + lappend res [reduce [a {key }]] + lappend res [reduce [a {1alpha}]] + set res "\n[join $res \n]" +} { +type source line 1587 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1589 file info.test cmd {info frame 0} proc ::a level 0} + +test info-30.17 {bs+nl in multi-body switch, direct} { + switch -regexp -- {key } \ + ^key { reduce [info frame 0] ;# 1601 } \ + \t### { } \ + {[0-9]*} { } +} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} { + proc abra {script} { + append script "\n# end of script" + uplevel 1 $script + } + set res [abra { + return "\ +[reduce [info frame 0]]";# line 1613, still line of 3 appended script + }] + rename abra {} + set res +} { type eval line 3 cmd {info frame 0} proc ::abra} +# { type source line 1606 file info.test cmd {info frame 0} proc ::abra} + +test info-30.19 {bs+nl in single-body switch, compiled} { + proc a {value} { + switch -regexp -- $value { + ^key { reduce \ + [info frame 0] } + \t { reduce \ + [info frame 0] } + {[0-9]*} { reduce \ + [info frame 0] } + } + } + set res {} + lappend res [a {key }] + lappend res [a {1alpha}] + set res "\n[join $res \n]" +} { +type source line 1624 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1628 file info.test cmd {info frame 0} proc ::a level 0} + +test info-30.20 {bs+nl in single-body switch, direct} { + switch -regexp -- {key } { \ + + ^key { reduce \ + [info frame 0] } + \t### { } + {[0-9]*} { } + } +} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + +test info-30.21 {bs+nl in if, full compiled} { + proc a {value} { + if {$value} \ + {info frame 0} \ + {info frame 0} ; # 1653 + } + set res {} + lappend res [reduce [a 1]] + lappend res [reduce [a 0]] + set res "\n[join $res \n]" +} { +type source line 1652 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1653 file info.test cmd {info frame 0} proc ::a level 0} + +test info-30.22 {bs+nl in computed word, key to array, compiled} { + proc a {} { + set tmp([set \ + res "\ +[reduce \ + [info frame 0]]"]) x ; #1668 + unset tmp + set res + } + set res [a] + rename a {} + set res +} { type source line 1668 file info.test cmd {info frame 0} proc ::a level 0} + +test info-30.23 {bs+nl in multi-body switch, full compiled} { + proc a {value} { + switch -exact -- $value \ + key { info frame 0; # 1680 } \ + xxx { info frame 0; # 1681 } \ + 000 { info frame 0; # 1682 } + } + set res {} + lappend res [reduce [a key]] + lappend res [reduce [a 000]] + set res "\n[join $res \n]" +} { +type source line 1680 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1682 file info.test cmd {info frame 0} proc ::a level 0} + +test info-30.24 {bs+nl in single-body switch, full compiled} { + proc a {value} { + switch -exact -- $value { + key { reduce \ + [info frame 0] } + xxx { reduce \ + [info frame 0] } + 000 { reduce \ + [info frame 0] } + } + } + set res {} + lappend res [a key] + lappend res [a 000] + set res "\n[join $res \n]" +} { +type source line 1696 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1700 file info.test cmd {info frame 0} proc ::a level 0} + +# ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} -- cgit v0.12