Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: |
* generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard,
EvalTokensStandard, Tcl_EvalEx, EvalEx, TclAdvanceContinuations,
TclEvalObjEx):
* generic/tclCmdMZ.c (Tcl_SwitchObjCmd, TclListLines):
* generic/tclCompCmds.c (*):
* generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv,
TclFreeCompileEnv, TclCompileScript):
* 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 parser, compiler, and execution with code and attendant data structures tracking the positions of continuation lines which are not visible in script Tcl_Obj*'s, to properly account for them while counting lines for #280. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | core-8-5-branch |
Files: | files | file ages | folders |
SHA1: |
c838caae315d224c64d058c46bb9b1de |
User & Date: | andreas_kupries 2009-08-25 21:01:05 |
Context
2009-08-26
| ||
02:26 | silence compiler warnings check-in: d7d129a6b6 user: dgp tags: core-8-5-branch | |
2009-08-25
| ||
21:01 | * generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard, EvalTokensStandard, Tcl_EvalEx, E... check-in: c838caae31 user: andreas_kupries tags: core-8-5-branch | |
2009-08-24
| ||
00:27 |
* macosx/tclMacOSXNotify.c: fix multiple issues with nested event loops when CoreFoundation notifi...check-in: 3c8d3403f3 user: das tags: core-8-5-branch | |
Changes
Changes to ChangeLog.
1 2 3 4 5 6 7 | 2009-08-24 Daniel Steffen <[email protected]> * macosx/tclMacOSXNotify.c: fix multiple issues with nested event loops when CoreFoundation notifier is running in embedded mode. (fixes problems in TkAqua Cocoa reported by Youness Alaoui on tcl-mac) 2009-08-21 Don Porter <[email protected]> | > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | 2009-08-25 Andreas Kupries <[email protected]> * generic/tclBasic.c (Tcl_CreateInterp, Tcl_EvalTokensStandard, EvalTokensStandard, Tcl_EvalEx, EvalEx, TclAdvanceContinuations, TclEvalObjEx): * generic/tclCmdMZ.c (Tcl_SwitchObjCmd, TclListLines): * generic/tclCompCmds.c (*): * generic/tclCompile.c (TclSetByteCodeFromAny, TclInitCompileEnv, TclFreeCompileEnv, TclCompileScript): * 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 parser, compiler, and execution with code and attendant data structures tracking the positions of continuation lines which are not visible in script Tcl_Obj*'s, to properly account for them while counting lines for #280. 2009-08-24 Daniel Steffen <[email protected]> * macosx/tclMacOSXNotify.c: fix multiple issues with nested event loops when CoreFoundation notifier is running in embedded mode. (fixes problems in TkAqua Cocoa reported by Youness Alaoui on tcl-mac) 2009-08-21 Don Porter <[email protected]> |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * 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.295.2.13 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include <float.h> #include <limits.h> #include <math.h> |
︙ | ︙ | |||
446 447 448 449 450 451 452 453 454 455 456 457 458 459 | iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); 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->activeVarTracePtr = NULL; iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); | > | 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 | iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); 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; iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo"); Tcl_IncrRefCount(iPtr->eiVar); |
︙ | ︙ | |||
3950 3951 3952 3953 3954 3955 3956 | * execute nested commands, and report * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { | | > | 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 | * execute nested commands, and report * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, NULL, NULL); } /* *---------------------------------------------------------------------- * * Tcl_EvalTokens -- * |
︙ | ︙ | |||
4034 4035 4036 4037 4038 4039 4040 | int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ { | | | > > > > > > > > > > > > > > > > > | 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 | int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ int flags) /* Collection of OR-ed bits that control the * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ { return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script); } int TclEvalEx( Tcl_Interp *interp, /* Interpreter in which to evaluate the * script. Also used for error reporting. */ const char *script, /* First character of script to evaluate. */ int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first NUL character. */ 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* 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; const unsigned int minObjs = 20; Tcl_Obj **objv, **objvSpace; int *expand, *lines, *lineSpace; Tcl_Token *tokenPtr; |
︙ | ︙ | |||
4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 | TclStackAlloc(interp, sizeof(CmdFrame)); Tcl_Obj **stackObjArray = (Tcl_Obj **) TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); int *expandStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); int *linesStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); /* TIP #280 Structures for tracking of command * locations. */ if (numBytes < 0) { numBytes = strlen(script); } Tcl_ResetResult(interp); savedVarFramePtr = iPtr->varFramePtr; | > > > > > > > > > > > > > > > > > | 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 | TclStackAlloc(interp, sizeof(CmdFrame)); Tcl_Obj **stackObjArray = (Tcl_Obj **) TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); int *expandStack = (int *) TclStackAlloc(interp, minObjs * sizeof(int)); int *linesStack = (int *) 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); } Tcl_ResetResult(interp); savedVarFramePtr = iPtr->varFramePtr; |
︙ | ︙ | |||
4101 4102 4103 4104 4105 4106 4107 | expand = expandStack; p = script; bytesLeft = numBytes; /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * | | | | | | | | 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 | expand = expandStack; p = script; bytesLeft = numBytes; /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * * 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. */ if (iPtr->evalFlags & TCL_EVAL_CTX) { /* * Path information comes out of the context. */ |
︙ | ︙ | |||
4171 4172 4173 4174 4175 4176 4177 | code = TCL_ERROR; goto error; } /* * 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 | | > > | > > > > | 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 | code = TCL_ERROR; goto error; } /* * 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, 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. 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. */ unsigned int objectsNeeded = 0; unsigned int numWords = parsePtr->numWords; |
︙ | ︙ | |||
4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 | * on a per-word basis, signaling dynamic words as needed. * Make the information available to the recursively called * evaluator as well, including the type of context (source * vs. eval). */ TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; } code = TclSubstTokens(interp, tokenPtr+1, | > > | > | 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 | * on a per-word basis, signaling dynamic words as needed. * Make the information available to the recursively called * evaluator as well, including the type of context (source * vs. eval). */ TclAdvanceLines(&wordLine, wordStart, tokenPtr->start); TclAdvanceContinuations (&wordLine, &wordCLNext, tokenPtr->start - outerScript); wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; } code = TclSubstTokens(interp, tokenPtr+1, tokenPtr->numComponents, NULL, wordLine, wordCLNext, outerScript); iPtr->evalFlags = 0; if (code != TCL_OK) { goto error; } objv[objectsUsed] = Tcl_GetObjResult(interp); |
︙ | ︙ | |||
4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 | expand[objectsUsed] = 1; objectsNeeded += (numElements ? numElements : 1); } else { expand[objectsUsed] = 0; objectsNeeded++; } } /* for loop */ if (expandRequested) { /* * Some word expansion was requested. Check for objv resize. */ Tcl_Obj **copy = objvSpace; | > > > > > | 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 | expand[objectsUsed] = 1; objectsNeeded += (numElements ? numElements : 1); } else { expand[objectsUsed] = 0; objectsNeeded++; } if (wordCLNext) { TclContinuationsEnterDerived (objv[objectsUsed], wordStart - outerScript, wordCLNext); } } /* for loop */ if (expandRequested) { /* * Some word expansion was requested. Check for objv resize. */ Tcl_Obj **copy = objvSpace; |
︙ | ︙ | |||
4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 | for (p = start; p < end; p++) { if (*p == '\n') { (*line)++; } } } /* *---------------------------------------------------------------------- * 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. * Should make it easier to redo the data structures if we find something more | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 | for (p = start; p < end; p++) { if (*p == '\n') { (*line)++; } } } /* *---------------------------------------------------------------------- * * 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. * Should make it easier to redo the data structures if we find something more |
︙ | ︙ | |||
5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 | * script to evaluate is a single literal it makes sense to look if * our context is one with absolute line numbers we can then track * into the literal itself too. * * See also tclCompile.c, TclInitCompileEnv, for the equivalent code * in the bytecode compiler. */ if (invoker == NULL) { /* * No context, force opening of our own. */ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 | * script to evaluate is a single literal it makes sense to look if * our context is one with absolute line numbers we can then track * into the literal itself too. * * See also tclCompile.c, TclInitCompileEnv, for the equivalent code * in the bytecode compiler. */ /* * 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; } if (invoker == NULL) { /* * No context, force opening of our own. */ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); |
︙ | ︙ | |||
5097 5098 5099 5100 5101 5102 5103 | * Absolute context to reuse. */ iPtr->invokeCmdFramePtr = ctxPtr; iPtr->evalFlags |= TCL_EVAL_CTX; result = TclEvalEx(interp, script, numSrcBytes, flags, | | > > > > > > > > > > | 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 | * Absolute context to reuse. */ iPtr->invokeCmdFramePtr = ctxPtr; iPtr->evalFlags |= TCL_EVAL_CTX; result = TclEvalEx(interp, script, numSrcBytes, flags, ctxPtr->line[word], NULL, script); if (pc) { /* * Death of SrcInfo reference. */ Tcl_DecrRefCount(ctxPtr->data.eval.path); } } 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; } } else { /* * Let the compiler/engine subsystem do the evaluation. * * TIP #280 The invoker provides us with the context for the script. * We transfer this to the byte code compiler. |
︙ | ︙ |
Changes to generic/tclCmdMZ.c.
︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003 Donal K. Fellows. * * 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.163.2.5 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclRegexp.h" static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); |
︙ | ︙ | |||
3849 3850 3851 3852 3853 3854 3855 | } if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; | | | 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 | } if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { /* * This is either a dynamic code word, when all elements are * relative to themselves, or something else less expected and * where we have no information. The result is the same in both * cases; tell the code to come that it doesn't know where it is, * which triggers reversion to the old behavior. |
︙ | ︙ | |||
3887 3888 3889 3890 3891 3892 3893 | } } /* * TIP #280: Make invoking context available to switch branch. */ | | | 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 | } } /* * TIP #280: Make invoking context available to switch branch. */ result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); if (splitObjs) { ckfree((char *) ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. */ |
︙ | ︙ | |||
4090 4091 4092 4093 4094 4095 4096 | * None. * *---------------------------------------------------------------------- */ void TclListLines( | | | | > | > > > > > > > > > > > | 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 | * None. * *---------------------------------------------------------------------- */ void TclListLines( 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. */ 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); /* Element */ listStr = next; if (*element == 0) { |
︙ | ︙ |
Changes to generic/tclCompCmds.c.
︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2004-2006 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | > > > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2004-2006 by Donal K. Fellows. * * 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.143.2.2 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Macro that encapsulates an efficiency trick that avoids a function call for * the simplest of compiles. The ANSI C "prototype" for this macro is: * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp, int word); */ #define CompileWord(envPtr, tokenPtr, interp, word) \ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ (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)); \ } /* * TIP #280: Remember the per-word line information of the current command. An * index is used instead of a pointer as recursive compilation may reallocate, * i.e. move, the array. This is also the reason to save the nuloc now, it may * change during the course of the function. * * Macro to encapsulate the variable definition and setup. */ #define DefineLineInformation \ 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: * * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp); */ |
︙ | ︙ | |||
148 149 150 151 152 153 154 | static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, | | > > > > > > | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 | static void FreeJumptableInfo(ClientData clientData); static void PrintJumptableInfo(ClientData clientData, Tcl_Obj *appendObj, ByteCode *codePtr, unsigned int pcOffset); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, int line, int* clNext); static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); static int CompileComparisonOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); 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. */ #define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */ #define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */ |
︙ | ︙ | |||
255 256 257 258 259 260 261 | * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); | | | < | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 | * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so * push the new value. This will need to be extended to push a value for * each argument. */ |
︙ | ︙ | |||
445 446 447 448 449 450 451 | * Otherwise, compile instructions to substitute its text without * catching, a catch instruction that resets the stack to what it was * before substituting the body, and then an instruction to eval the body. * Care has to be taken to register the correct startOffset for the catch * range so that errors in the substitution are not catched [Bug 219184] */ | | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 | * Otherwise, compile instructions to substitute its text without * catching, a catch instruction that resets the stack to what it was * before substituting the body, and then an instruction to eval the body. * Care has to be taken to register the correct startOffset for the catch * range so that errors in the substitution are not catched [Bug 219184] */ SetLineInformation (1); if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); ExceptionRangeEnds(envPtr, range); } else { CompileTokens(envPtr, cmdTokenPtr, interp); ExceptionRangeStarts(envPtr, range); |
︙ | ︙ | |||
917 918 919 920 921 922 923 | loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); ExceptionRangeStarts(envPtr, loopRange); /* * Compile the loop body itself. It should be stack-neutral. */ | | | 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 | loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); ExceptionRangeStarts(envPtr, loopRange); /* * Compile the loop body itself. It should be stack-neutral. */ SetLineInformation (4); CompileBody(envPtr, bodyTokenPtr, interp); TclEmitOpcode( INST_POP, envPtr); /* * Both exception target ranges (error and loop) end here. */ |
︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 | bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Inline compile the initial command. */ | | | 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 | bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE); nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); /* * Inline compile the initial command. */ SetLineInformation (1); CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); /* * Jump to the evaluation of the condition. This code uses the "loop * rotation" optimisation (which eliminates one branch from the loop). * "for start cond next body" produces then: |
︙ | ︙ | |||
1466 1467 1468 1469 1470 1471 1472 | TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); /* * Compile the loop body. */ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); | | | | | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 | TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup); /* * Compile the loop body. */ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); SetLineInformation (4); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Compile the "next" subcommand. */ envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); SetLineInformation (3); CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth; /* * Compile the test expression then emit the conditional jump that * terminates the for. */ testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; testCodeOffset += 3; } SetLineInformation (2); envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); |
︙ | ︙ | |||
1749 1750 1751 1752 1753 1754 1755 | */ loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { | | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 | */ loopIndex = 0; for (i = 0, tokenPtr = parsePtr->tokenPtr; i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { SetLineInformation (i); CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); } else { TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); } |
︙ | ︙ | |||
1781 1782 1783 1784 1785 1786 1787 | TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* * Inline compile the loop body. */ | | | 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 | TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); /* * Inline compile the loop body. */ SetLineInformation (bodyIndex); ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* |
︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 | */ realCond = 0; if (!boolVal) { compileScripts = 0; } } else { | | | 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 | */ realCond = 0; if (!boolVal) { compileScripts = 0; } } else { SetLineInformation (wordIdx); Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { TclExpandJumpFixupArray(&jumpFalseFixupArray); } jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; |
︙ | ︙ | |||
2162 2163 2164 2165 2166 2167 2168 | } /* * Compile the "then" command body. */ if (compileScripts) { | | | 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 | } /* * Compile the "then" command body. */ if (compileScripts) { SetLineInformation (wordIdx); envPtr->currStackDepth = savedStackDepth; CompileBody(envPtr, tokenPtr, interp); } if (realCond) { /* * Jump to the end of the "if" command. Both jumpFalseFixupArray |
︙ | ︙ | |||
2250 2251 2252 2253 2254 2255 2256 | } if (compileScripts) { /* * Compile the else command body. */ | | | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 | } if (compileScripts) { /* * Compile the else command body. */ SetLineInformation (wordIdx); CompileBody(envPtr, tokenPtr, interp); } /* * Make sure there are no words after the else clause. */ |
︙ | ︙ | |||
2352 2353 2354 2355 2356 2357 2358 | if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); | | | < | 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 | if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); /* * If an increment is given, push it, but see first if it's a small * integer. */ haveImmValue = 0; |
︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 | if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } if (!haveImmValue) { PushLiteral(envPtr, word, numBytes); } } else { | | | 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 | if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) { haveImmValue = 1; } if (!haveImmValue) { PushLiteral(envPtr, word, numBytes); } } else { SetLineInformation (2); CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1. */ haveImmValue = 1; } /* |
︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 | * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include * namespace qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); | | | < | 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 | * frame slot (entry in the array of local vars) if we are compiling a * procedure body and if the name is simple text that does not include * namespace qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); /* * If we are doing an assignment, push the new value. In the no values * case, create an empty object. */ if (numWords > 2) { |
︙ | ︙ | |||
2602 2603 2604 2605 2606 2607 2608 | for (idx=0 ; idx<numWords-2 ; idx++) { tokenPtr = TokenAfter(tokenPtr); /* * Generate the next variable name. */ | | | | 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 | for (idx=0 ; idx<numWords-2 ; idx++) { tokenPtr = TokenAfter(tokenPtr); /* * Generate the next variable name. */ PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, idx+2); /* * Emit instructions to get the idx'th item out of the list value on * the stack and assign it to the variable. */ if (simpleVarName) { |
︙ | ︙ | |||
2939 2940 2941 2942 2943 2944 2945 | * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); | | | < | 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 | * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); /* * Push the "index" args and the new element value. */ for (i=2 ; i<parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); |
︙ | ︙ | |||
3441 3442 3443 3444 3445 3446 3447 | * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); | | | < | 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 | * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); /* * If we are doing an assignment, push the new value. */ if (isAssignment) { valueTokenPtr = TokenAfter(varTokenPtr); |
︙ | ︙ | |||
3724 3725 3726 3727 3728 3729 3730 | Tcl_IncrRefCount(copy); exactMatch = TclMatchIsTrivial(TclGetString(copy)); TclDecrRefCount(copy); } PushLiteral(envPtr, str, length); } else { | | | 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 | Tcl_IncrRefCount(copy); exactMatch = TclMatchIsTrivial(TclGetString(copy)); TclDecrRefCount(copy); } PushLiteral(envPtr, str, length); } else { SetLineInformation (i+1+nocase); CompileTokens(envPtr, tokenPtr, interp); } tokenPtr = TokenAfter(tokenPtr); } /* * Push the matcher. |
︙ | ︙ | |||
3790 3791 3792 3793 3794 3795 3796 | char buf[TCL_INTEGER_SPACE]; int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size); len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { | | | 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 | char buf[TCL_INTEGER_SPACE]; int len = Tcl_NumUtfChars(tokenPtr[1].start, tokenPtr[1].size); len = sprintf(buf, "%d", len); PushLiteral(envPtr, buf, len); } else { SetLineInformation (1); CompileTokens(envPtr, tokenPtr, interp); TclEmitOpcode(INST_STR_LEN, envPtr); } return TCL_OK; } /* |
︙ | ︙ | |||
3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 | enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; /* What kind of switch are we doing? */ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ int *bodyLines; /* Array of line numbers for body list * items. */ int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ int contFixIndex; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if * there aren't any. */ int contFixCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ int savedStackDepth = envPtr->currStackDepth; int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ int isListedArms = 0; int i, valueIndex; DefineLineInformation; /* TIP #280 */ /* * Only handle the following versions: * switch ?--? word {pattern body ...} * switch -exact ?--? word {pattern body ...} * switch -glob ?--? word {pattern body ...} * switch -regexp ?--? word {pattern body ...} | > > | 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 | enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode; /* What kind of switch are we doing? */ Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ 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. */ JumpFixup *fixupArray; /* Array of forward-jump fixup records. */ int *fixupTargetArray; /* Array of places for fixups to point at. */ int fixupCount; /* Number of places to fix up. */ int contFixIndex; /* Where the first of the jumps due to a group * of continuation bodies starts, or -1 if * there aren't any. */ int contFixCount; /* Number of continuation bodies pointing to * the current (or next) real body. */ int savedStackDepth = envPtr->currStackDepth; int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ int isListedArms = 0; int i, valueIndex; DefineLineInformation; /* TIP #280 */ int* clNext = envPtr->clNext; /* * Only handle the following versions: * switch ?--? word {pattern body ...} * switch -exact ?--? word {pattern body ...} * switch -glob ?--? word {pattern body ...} * switch -regexp ?--? word {pattern body ...} |
︙ | ︙ | |||
4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 | return TCL_ERROR; } isListedArms = 1; bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); bodyLines = (int *) ckalloc(sizeof(int) * numWords); /* * Locate the start of the arms within the overall word. */ bline = mapPtr->loc[eclIndex].line[valueIndex+1]; p = tokenStartPtr = tokenPtr[1].start; | > | 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 | return TCL_ERROR; } isListedArms = 1; 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. */ bline = mapPtr->loc[eclIndex].line[valueIndex+1]; p = tokenStartPtr = tokenPtr[1].start; |
︙ | ︙ | |||
4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 | if ((isTokenBraced && *(tokenStartPtr++) != '}') || (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size && !isspace(UCHAR(*tokenStartPtr)))) { ckfree((char *) argv); ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); return TCL_ERROR; } /* * TIP #280: Now determine the line the list element starts on * (there is no need to do it earlier, due to the possibility of * aborting, see above). */ TclAdvanceLines(&bline, p, bodyTokenArray[i].start); bodyLines[i] = bline; p = bodyTokenArray[i].start; while (isspace(UCHAR(*tokenStartPtr))) { tokenStartPtr++; if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) { break; } | > > > > | 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 | if ((isTokenBraced && *(tokenStartPtr++) != '}') || (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size && !isspace(UCHAR(*tokenStartPtr)))) { ckfree((char *) argv); ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); ckfree((char *) bodyNext); return TCL_ERROR; } /* * TIP #280: Now determine the line the list element starts on * (there is no need to do it earlier, due to the possibility of * aborting, see above). */ 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))) { tokenStartPtr++; if (tokenStartPtr >= tokenPtr[1].start+tokenPtr[1].size) { break; } |
︙ | ︙ | |||
4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 | * to defeat the code above) and we should bail out. */ if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { /* * Odd number of words (>1) available, or no words at all available. * Both are error cases, so punt and let the interpreted-version * generate the error message. Note that the second case probably * should get caught earlier, but it's easy to check here again anyway * because it'd cause a nasty crash otherwise. */ return TCL_ERROR; } else { /* * Multi-word definition of patterns & actions. */ bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); bodyLines = (int *) ckalloc(sizeof(int) * numWords); bodyTokenArray = NULL; for (i=0 ; i<numWords ; i++) { /* * We only handle the very simplest case. Anything more complex is * a good reason to go to the interpreted case anyway due to * traces, etc. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr->numComponents != 1) { ckfree((char *) bodyToken); ckfree((char *) bodyLines); return TCL_ERROR; } bodyToken[i] = tokenPtr+1; /* * TIP #280: Copy line information from regular cmd info. */ bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; tokenPtr = TokenAfter(tokenPtr); } } /* * Fall back to interpreted if the last body is a continuation (it's * illegal, but this makes the error happen at the right time). */ if (bodyToken[numWords-1]->size == 1 && bodyToken[numWords-1]->start[0] == '-') { ckfree((char *) bodyToken); ckfree((char *) bodyLines); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } return TCL_ERROR; } /* * Now we commit to generating code; the parsing stage per se is done. * First, we push the value we're matching against on the stack. */ | > > > > > | | 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 | * to defeat the code above) and we should bail out. */ if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); ckfree((char *) bodyLines); ckfree((char *) bodyNext); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { /* * Odd number of words (>1) available, or no words at all available. * Both are error cases, so punt and let the interpreted-version * generate the error message. Note that the second case probably * should get caught earlier, but it's easy to check here again anyway * because it'd cause a nasty crash otherwise. */ return TCL_ERROR; } else { /* * Multi-word definition of patterns & actions. */ 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 ; i<numWords ; i++) { /* * We only handle the very simplest case. Anything more complex is * a good reason to go to the interpreted case anyway due to * traces, etc. */ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr->numComponents != 1) { ckfree((char *) bodyToken); ckfree((char *) bodyLines); ckfree((char *) bodyNext); return TCL_ERROR; } bodyToken[i] = tokenPtr+1; /* * TIP #280: Copy line information from regular cmd info. */ bodyLines[i] = mapPtr->loc[eclIndex].line[valueIndex+1+i]; bodyNext[i] = mapPtr->loc[eclIndex].next[valueIndex+1+i]; tokenPtr = TokenAfter(tokenPtr); } } /* * Fall back to interpreted if the last body is a continuation (it's * illegal, but this makes the error happen at the right time). */ if (bodyToken[numWords-1]->size == 1 && bodyToken[numWords-1]->start[0] == '-') { ckfree((char *) bodyToken); ckfree((char *) bodyLines); ckfree((char *) bodyNext); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } return TCL_ERROR; } /* * Now we commit to generating code; the parsing stage per se is done. * First, we push the value we're matching against on the stack. */ SetLineInformation (valueIndex); CompileTokens(envPtr, valueTokenPtr, interp); /* * Check if we can generate a jump table, since if so that's faster than * doing an explicit compare with each body. Note that we're definitely * over-conservative with determining whether we can do the jump table, * but it handles the most common case well enough. |
︙ | ︙ | |||
4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 | mustGenerate = 0; /* * Compile the body of the arm. */ envPtr->line = bodyLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); /* * Compile a jump in to the end of the command if this body is * anything other than a user-supplied default arm (to either skip * over the remaining bodies or the code that generates an empty * result). | > | 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 | mustGenerate = 0; /* * Compile the body of the arm. */ envPtr->line = bodyLines[i+1]; /* TIP #280 */ envPtr->clNext = bodyNext[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); /* * Compile a jump in to the end of the command if this body is * anything other than a user-supplied default arm (to either skip * over the remaining bodies or the code that generates an empty * result). |
︙ | ︙ | |||
4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 | /* * Clean up all our temporary space and return. */ ckfree((char *) finalFixups); ckfree((char *) bodyToken); ckfree((char *) bodyLines); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } return TCL_OK; } /* | > | 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 | /* * Clean up all our temporary space and return. */ ckfree((char *) finalFixups); ckfree((char *) bodyToken); ckfree((char *) bodyLines); ckfree((char *) bodyNext); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } return TCL_OK; } /* |
︙ | ︙ | |||
4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 | * because we may have synthesized the tokens in a non-standard * pattern. */ TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth + 1; envPtr->line = bodyLines[i+1]; /* TIP #280 */ TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); if (!foundDefault) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, fixupArray+fixupCount); fixupCount++; fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); } } /* * Clean up all our temporary space and return. */ ckfree((char *) bodyToken); ckfree((char *) bodyLines); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } /* * Discard the value we are matching against unless we've had a default * clause (in which case it will already be gone due to the code at the | > > | 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 | * because we may have synthesized the tokens in a non-standard * pattern. */ 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) { TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, fixupArray+fixupCount); fixupCount++; fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); } } /* * Clean up all our temporary space and return. */ ckfree((char *) bodyToken); ckfree((char *) bodyLines); ckfree((char *) bodyNext); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } /* * Discard the value we are matching against unless we've had a default * clause (in which case it will already be gone due to the code at the |
︙ | ︙ | |||
4788 4789 4790 4791 4792 4793 4794 | testCodeOffset = CurrentOffset(envPtr); } /* * Compile the loop body. */ | | | | 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 | testCodeOffset = CurrentOffset(envPtr); } /* * Compile the loop body. */ SetLineInformation (2); bodyCodeOffset = ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode(INST_POP, envPtr); /* * Compile the test expression then emit the conditional jump that * terminates the while. We already know it's a simple word. */ if (loopMayEnd) { testCodeOffset = CurrentOffset(envPtr); jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { bodyCodeOffset += 3; testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; SetLineInformation (1); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; jumpDist = CurrentOffset(envPtr) - bodyCodeOffset; if (jumpDist > 127) { TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr); } else { |
︙ | ︙ | |||
4873 4874 4875 4876 4877 4878 4879 | Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */ int *localIndexPtr, /* Must not be NULL. */ int *simpleVarNamePtr, /* Must not be NULL. */ int *isScalarPtr, /* Must not be NULL. */ | | > | 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 | Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Token *varTokenPtr, /* Points to a variable token. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX. */ 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* clNext) /* Reference to offset of next hidden cont. line */ { register const char *p; const char *name, *elName; register int i, n; Tcl_Token *elemTokenPtr = NULL; int nameChars, elNameChars, simpleVarName, localIndex; int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; |
︙ | ︙ | |||
5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 | /* * Compile the element script, if any. */ if (elName != NULL) { if (elNameChars) { envPtr->line = line; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { PushLiteral(envPtr, "", 0); } } } else { /* * The var name isn't simple: compile and push it. */ envPtr->line = line; CompileTokens(envPtr, varTokenPtr, interp); } if (removedParen) { ++varTokenPtr[removedParen].size; } if (allocedTokens) { | > > | 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 | /* * Compile the element script, if any. */ if (elName != NULL) { if (elNameChars) { envPtr->line = line; envPtr->clNext = clNext; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { PushLiteral(envPtr, "", 0); } } } else { /* * The var name isn't simple: compile and push it. */ envPtr->line = line; envPtr->clNext = clNext; CompileTokens(envPtr, varTokenPtr, interp); } if (removedParen) { ++varTokenPtr[removedParen].size; } if (allocedTokens) { |
︙ | ︙ | |||
5845 5846 5847 5848 5849 5850 5851 | * be called at runtime. */ for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, 1); | | | < | 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 | * be called at runtime. */ for(; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, 1); PushVarNameWord(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); if((localIndex < 0) || !isScalar) { return TCL_ERROR; } TclEmitInstInt4(INST_UPVAR, localIndex, envPtr); } |
︙ | ︙ | |||
5938 5939 5940 5941 5942 5943 5944 | localTokenPtr = tokenPtr; for(i=4; i<=numWords; i+=2) { otherTokenPtr = TokenAfter(localTokenPtr); localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, 1); | | | < | 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 | localTokenPtr = tokenPtr; for(i=4; i<=numWords; i+=2) { otherTokenPtr = TokenAfter(localTokenPtr); localTokenPtr = TokenAfter(otherTokenPtr); CompileWord(envPtr, otherTokenPtr, interp, 1); PushVarNameWord(interp, localTokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); if((localIndex < 0) || !isScalar) { return TCL_ERROR; } TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr); } |
︙ | ︙ | |||
6440 6441 6442 6443 6444 6445 6446 | * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); | | | | 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 | * to emit code to compute and push the name at runtime. We use a frame * slot (entry in the array of local vars) if we are compiling a procedure * body and if the name is simple text that does not include namespace * qualifiers. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarNameWord(interp, tokenPtr, envPtr, TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, 1); /* * Emit instruction to check the variable for existence. */ if (simpleVarName) { if (isScalar) { |
︙ | ︙ |
Changes to generic/tclCompile.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclCompile.c -- * * This file contains procedures that compile Tcl commands or parts of * commands (like quoted strings or nested sub-commands) into a sequence * of instructions ("bytecodes"). * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclCompile.c -- * * This file contains procedures that compile Tcl commands or parts of * commands (like quoted strings or nested sub-commands) into a sequence * of instructions ("bytecodes"). * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * 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.146.2.11 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Table of all AuxData types. |
︙ | ︙ | |||
427 428 429 430 431 432 433 | const char *stringPtr, int maxChars); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int len, | | > | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 | const char *stringPtr, int maxChars); /* * TIP #280: Helper for building the per-word line information of all compiled * commands. */ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, int len, int numWords, int line, int* clNext, int **lines, CompileEnv* envPtr); /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. */ Tcl_ObjType tclByteCodeType = { |
︙ | ︙ | |||
483 484 485 486 487 488 489 490 491 492 493 494 495 496 | CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; int length, result = TCL_OK; const char *stringPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { if (Tcl_LinkVar(interp, "tcl_traceCompile", (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); } | > | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 | CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; int length, result = TCL_OK; const char *stringPtr; ContLineLoc* clLocPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { if (Tcl_LinkVar(interp, "tcl_traceCompile", (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); } |
︙ | ︙ | |||
504 505 506 507 508 509 510 511 512 513 514 515 516 517 | * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and * use to initialize the tracking in the compiler. This information was * stored by TclCompEvalObj and ProcCompileProc. */ TclInitCompileEnv(interp, &compEnv, stringPtr, length, iPtr->invokeCmdFramePtr, iPtr->invokeWord); TclCompileScript(interp, stringPtr, length, &compEnv); /* * Successful compilation. Add a "done" instruction at the end. */ TclEmitOpcode(INST_DONE, &compEnv); | > > > > > > > > > > > > > > > > > > > | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and * use to initialize the tracking in the compiler. This information was * stored by TclCompEvalObj and ProcCompileProc. */ 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); /* * Successful compilation. Add a "done" instruction at the end. */ TclEmitOpcode(INST_DONE, &compEnv); |
︙ | ︙ | |||
978 979 980 981 982 983 984 985 986 987 988 989 990 991 | } } } TclStackFree(interp, ctxPtr); } envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; envPtr->mallocedAuxDataArray = 0; } /* | > > > > > > > > > | 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 | } } } TclStackFree(interp, ctxPtr); } /* * 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; envPtr->mallocedAuxDataArray = 0; } /* |
︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 | } if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { ckfree((char *) envPtr->extCmdMapPtr); } } /* *---------------------------------------------------------------------- * * TclWordKnownAtCompileTime -- * | > > > > > > > > > > | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 | } if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } 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); } } /* *---------------------------------------------------------------------- * * TclWordKnownAtCompileTime -- * |
︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 | Tcl_Token *tokenPtr; int bytesLeft, isFirstCmd, wordIdx, currCmdIndex; int commandLength, objIndex; Tcl_DString ds; /* TIP #280 */ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat, cmdLine; Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); Tcl_DStringInit(&ds); if (numBytes < 0) { numBytes = strlen(script); | > | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 | Tcl_Token *tokenPtr; int bytesLeft, isFirstCmd, wordIdx, currCmdIndex; int commandLength, objIndex; Tcl_DString ds; /* TIP #280 */ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; int *wlines, wlineat, cmdLine; int* clNext; Tcl_Parse *parsePtr = (Tcl_Parse *) TclStackAlloc(interp, sizeof(Tcl_Parse)); Tcl_DStringInit(&ds); if (numBytes < 0) { numBytes = strlen(script); |
︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 | * Each iteration through the following loop compiles the next command * from the script. */ p = script; bytesLeft = numBytes; cmdLine = envPtr->line; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { /* * Compile bytecodes to report the parse error at runtime. */ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, | > | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 | * Each iteration through the following loop compiles the next command * from the script. */ p = script; bytesLeft = numBytes; cmdLine = envPtr->line; clNext = envPtr->clNext; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { /* * Compile bytecodes to report the parse error at runtime. */ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, |
︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 1290 | * information. The map first contain full per-word line * information for use by the compiler. This is later replaced by * a reduced form which signals non-literal words, stored in * 'wlines'. */ TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, | > > | | | > > | 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 | * information. The map first contain full per-word line * information for use by the compiler. This is later replaced by * a reduced form which signals non-literal words, stored in * 'wlines'. */ 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, clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; /* * Each iteration of the following loop compiles one word from the * command. */ for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; wordIdx < parsePtr->numWords; wordIdx++, 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. */ TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); |
︙ | ︙ | |||
1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 | * reason. Register the literal's location for use by * uplevel, etc. commands, should they encounter it * unmodified. We care only if the we are in a context * which already allows absolute counting. */ objIndex = TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); } TclEmitPush(objIndex, envPtr); } /* for loop */ /* * Emit an invoke instruction for the command. We skip this if a * compile procedure was found for the command. | > > > > > > | 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 | * reason. Register the literal's location for use by * uplevel, etc. commands, should they encounter it * unmodified. We care only if the we are in a context * which already allows absolute counting. */ 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 */ /* * Emit an invoke instruction for the command. We skip this if a * compile procedure was found for the command. |
︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 | /* * TIP #280: Free full form of per-word line data and insert the * reduced form now */ ckfree((char *) eclPtr->loc[wlineat].line); eclPtr->loc[wlineat].line = wlines; } /* end if parsePtr->numWords > 0 */ /* * Advance to the next command in the script. */ next = parsePtr->commandStart + parsePtr->commandSize; bytesLeft -= next - p; p = next; /* * TIP #280: Track lines in the just compiled command. */ TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); Tcl_FreeParse(parsePtr); } while (bytesLeft > 0); /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. * | > > > | 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 | /* * TIP #280: Free full form of per-word line data and insert the * reduced form now */ 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 */ /* * Advance to the next command in the script. */ next = parsePtr->commandStart + parsePtr->commandSize; bytesLeft -= next - p; p = next; /* * TIP #280: Track lines in the just compiled command. */ TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source); Tcl_FreeParse(parsePtr); } while (bytesLeft > 0); /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. * |
︙ | ︙ | |||
1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 | Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; const char *name, *p; int numObjsToConcat, nameBytes, localVarName, localVar; int length, i; unsigned char *entryCodeNext = envPtr->codeNext; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); break; case TCL_TOKEN_BS: length = Tcl_UtfBackslash(tokenPtr->start, NULL, buffer); Tcl_DStringAppend(&textBuffer, buffer, length); break; case TCL_TOKEN_COMMAND: /* * Push any accumulated chars appearing before the command. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); numObjsToConcat++; break; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 | Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; const char *name, *p; 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 * 'EvalTokensStandard()' (see file "tclBasic.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; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); break; 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: /* * Push any accumulated chars appearing before the command. */ if (Tcl_DStringLength(&textBuffer) > 0) { int literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); if (numCL) { TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, numCL, clPosition); } numCL = 0; } TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); numObjsToConcat++; break; |
︙ | ︙ | |||
1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 | if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; } /* * If necessary, concatenate the parts of the word. */ while (numObjsToConcat > 255) { | > > > > > > | 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 | if (Tcl_DStringLength(&textBuffer) > 0) { int literal; literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; if (numCL) { TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, numCL, clPosition); } numCL = 0; } /* * If necessary, concatenate the parts of the word. */ while (numObjsToConcat > 255) { |
︙ | ︙ | |||
1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 | * If the tokens yielded no instructions, push an empty string. */ if (envPtr->codeNext == entryCodeNext) { TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } Tcl_DStringFree(&textBuffer); } /* *---------------------------------------------------------------------- * * TclCompileCmdWord -- * | > > > > > > > > > | 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 | * If the tokens yielded no instructions, push an empty string. */ if (envPtr->codeNext == entryCodeNext) { 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); } } /* *---------------------------------------------------------------------- * * TclCompileCmdWord -- * |
︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 | * information. */ int srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, int len, int numWords, int line, | > | > > > > | > > > | 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 | * information. */ int srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, int len, int numWords, int line, int* clNext, int **wlines, CompileEnv* envPtr) { ECL *ePtr; const char *last; int wordIdx, wordLine, *wwlines; int* wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* * Expand the ECL array by allocating more storage from the heap. The * currently allocated ECL entries are stored from eclPtr->loc[0] up * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). */ size_t currElems = eclPtr->nloc; size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); eclPtr->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes); eclPtr->nloc = newElems; } 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 ; wordIdx<numWords; wordIdx++, tokenPtr += tokenPtr->numComponents + 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; } *wlines = wwlines; eclPtr->nuloc ++; } |
︙ | ︙ |
Changes to generic/tclCompile.h.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * 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.90.2.7 2009/08/25 21:01:05 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION #define _TCLCOMPILATION 1 #include "tclInt.h" |
︙ | ︙ | |||
128 129 130 131 132 133 134 135 136 137 138 139 140 141 | */ typedef struct ECL { int srcOffset; /* Command location to find the entry. */ int nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ } ECL; typedef struct ExtCmdLoc { int type; /* Context type. */ Tcl_Obj *path; /* Path of the sourced file the command is * in. */ ECL *loc; /* Command word locations (lines). */ | > > > | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | */ typedef struct ECL { int srcOffset; /* Command location to find the entry. */ 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 { int type; /* Context type. */ Tcl_Obj *path; /* Path of the sourced file the command is * in. */ ECL *loc; /* Command word locations (lines). */ |
︙ | ︙ | |||
302 303 304 305 306 307 308 309 310 311 312 313 314 315 | int line; /* First line of the script, based on the * invoking context, then the line of the * command currently compiled. */ int atCmdStart; /* Flag to say whether an INST_START_CMD * should be issued; they should never be * issued repeatedly, as that is significantly * inefficient. */ } CompileEnv; /* * The structure defining the bytecode instructions resulting from compiling a * Tcl script. Note that this structure is variable length: a single heap * object is allocated to hold the ByteCode structure immediately followed by * the code bytes, the literal object array, the ExceptionRange array, the | > > > > > > > | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 | int line; /* First line of the script, based on the * invoking context, then the line of the * command currently compiled. */ int atCmdStart; /* Flag to say whether an INST_START_CMD * 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; /* * The structure defining the bytecode instructions resulting from compiling a * Tcl script. Note that this structure is variable length: a single heap * object is allocated to hold the ByteCode structure immediately followed by * the code bytes, the literal object array, the ExceptionRange array, the |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * 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.362.2.8 2009/08/25 21:01:05 andreas_kupries Exp $ */ #ifndef _TCLINT #define _TCLINT /* * Some numerics configuration options |
︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 | typedef struct CFWordBC { CmdFrame* framePtr; /* CmdFrame to acess */ int pc; /* Instruction pointer of a command in ExtCmdLoc.loc[.] */ int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */ struct CFWordBC* prevPtr; } CFWordBC; /* * 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'. * * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx. * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 | typedef struct CFWordBC { CmdFrame* framePtr; /* CmdFrame to acess */ int pc; /* Instruction pointer of a command in ExtCmdLoc.loc[.] */ int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */ struct CFWordBC* prevPtr; } 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'. * * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx. * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list |
︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 | * CFWord*" (See tclBasic.c). This allows * commands like uplevel, eval, etc. to find * location information for their arguments, * if they are a proper literal argument to an * invoking command. Alt view: An index to the * CmdFrame stack keyed by command argument * holders. */ /* * TIP #268. The currently active selection mode, i.e. the package require * preferences. */ int packagePrefer; /* Current package selection mode. */ | > > > > > > > > > > | 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 | * CFWord*" (See tclBasic.c). This allows * commands like uplevel, eval, etc. to find * location information for their arguments, * if they are a proper literal argument to an * 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. */ int packagePrefer; /* Current package selection mode. */ |
︙ | ︙ | |||
2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 | /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp* interp, Tcl_Obj* objv[], int objc, CmdFrame* cf); MODULE_SCOPE void TclArgumentRelease(Tcl_Interp* interp, Tcl_Obj* objv[], int objc); MODULE_SCOPE void TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj, | > | 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 | /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside world: *---------------------------------------------------------------- */ 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, Tcl_Obj* objv[], int objc, CmdFrame* cf); MODULE_SCOPE void TclArgumentRelease(Tcl_Interp* interp, Tcl_Obj* objv[], int objc); MODULE_SCOPE void TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj, |
︙ | ︙ | |||
2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 | int ptnLen, int flags); MODULE_SCOPE double TclCeil(mp_int *a); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); 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, | > > > > | > | 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 | int ptnLen, int flags); MODULE_SCOPE double TclCeil(mp_int *a); MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); 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* clNextOuter, CONST char* outerScript); MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclFileCopyCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclFileDeleteCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclFileMakeDirsCmd(Tcl_Interp *interp, |
︙ | ︙ | |||
2571 2572 2573 2574 2575 2576 2577 | MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ | | | | 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 | MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ 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[], Tcl_PackageInitProc **procPtrs[], Tcl_LoadHandle *handlePtr, ClientData *clientDataPtr, Tcl_FSUnloadFileProc **unloadProcPtr); |
︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 | int numBytes); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); 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, | | > | 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 | int numBytes); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); 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* clNextOuter, CONST char* outerScript); MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_PackageInitProc *TclpFindSymbol(Tcl_Interp *interp, Tcl_LoadHandle loadHandle, const char *symbol); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, |
︙ | ︙ |
Changes to generic/tclObj.c.
︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 2001 by ActiveState Corporation. * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 2001 by ActiveState Corporation. * Copyright (c) 2005 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * 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.139.2.3 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" #include "tommath.h" #include <float.h> #include <math.h> |
︙ | ︙ | |||
49 50 51 52 53 54 55 | * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; char *tclEmptyStringRep = &tclEmptyString; | | > > > > > > > > > > > > > > > > > > > > > > | | | | < > | > > > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | * Pointer to a heap-allocated string of length zero that the Tcl core uses as * the value of an empty string representation for an object. This value is * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; char *tclEmptyStringRep = &tclEmptyString; /* * 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; static void ContLineLocFree (char* clientData); static void TclThreadFinalizeObjects (ClientData clientData); static ThreadSpecificData* TclGetTables (void); /* * Nested Tcl_Obj deletion management support * * All context references used in the object freeing code are pointers to this * structure; every thread will have its own structure instance. The purpose * of this structure is to allow deeply nested collections of Tcl_Objs to be |
︙ | ︙ | |||
414 415 416 417 418 419 420 421 422 423 424 425 426 427 | * Tcl_Obj's to NULL; the memory finalization will take care of releasing * memory for us. */ Tcl_MutexLock(&tclObjMutex); tclFreeObjList = NULL; Tcl_MutexUnlock(&tclObjMutex); } /* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- * * This function is called to register a new Tcl object type in the table | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 | * Tcl_Obj's to NULL; the memory finalization will take care of releasing * memory for us. */ Tcl_MutexLock(&tclObjMutex); tclFreeObjList = NULL; Tcl_MutexUnlock(&tclObjMutex); } /* *---------------------------------------------------------------------- * * 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;i<num;i++) { clLocPtr->loc[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 -- * * This function is called to register a new Tcl object type in the table |
︙ | ︙ | |||
620 621 622 623 624 625 626 | * allocated by the currently executing thread. */ if (!TclInExit()) { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; int isNew; | | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 | * allocated by the currently executing thread. */ if (!TclInExit()) { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; int isNew; ThreadSpecificData *tsdPtr = TclGetTables(); if (tsdPtr->objThreadMap == NULL) { tsdPtr->objThreadMap = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; |
︙ | ︙ | |||
877 878 879 880 881 882 883 884 885 886 887 888 889 890 | Tcl_MutexLock(&tclObjMutex); ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } ObjDeletionUnlock(context); } } #else /* TCL_MEM_DEBUG */ void TclFreeObj( register Tcl_Obj *objPtr) /* The object to be freed. */ { | > > > > > > > > > > > > > > > > > > > > > > | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 | Tcl_MutexLock(&tclObjMutex); ckfree((char *) objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } 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 */ void TclFreeObj( register Tcl_Obj *objPtr) /* The object to be freed. */ { |
︙ | ︙ | |||
942 943 944 945 946 947 948 949 950 951 952 953 954 955 | } TclFreeObjStorage(objToFree); TclIncrObjsFreed(); } ObjDeletionUnlock(context); } } } #endif /* *---------------------------------------------------------------------- * * TclObjBeingDeleted -- | > > > > > > > > > > > > > > > > > > > > > > | 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 | } TclFreeObjStorage(objToFree); TclIncrObjsFreed(); } 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 /* *---------------------------------------------------------------------- * * TclObjBeingDeleted -- |
︙ | ︙ |
Changes to generic/tclParse.c.
︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclParse.c,v 1.62.2.3 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" /* * The following table provides parsing information about each possible 8-bit * character. The table is designed to be referenced with either signed or |
︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 | */ TclStackFree(interp, parsePtr); return "$"; } code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, | | | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 | */ TclStackFree(interp, parsePtr); return "$"; } code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; } objPtr = Tcl_GetObjResult(interp); /* |
︙ | ︙ | |||
2059 2060 2061 2062 2063 2064 2065 | /* * Next, substitute the parsed tokens just as in normal Tcl evaluation. */ endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokensLeft = parsePtr->numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, | | | 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 | /* * Next, substitute the parsed tokens just as in normal Tcl evaluation. */ endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; tokensLeft = parsePtr->numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, &tokensLeft, 1, NULL, NULL); if (code == TCL_OK) { Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); if (errMsg != NULL) { Tcl_SetObjResult(interp, errMsg); Tcl_DecrRefCount(errMsg); return NULL; |
︙ | ︙ | |||
2104 2105 2106 2107 2108 2109 2110 | } Tcl_DecrRefCount(errMsg); } return result; } code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, | | | 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 | } Tcl_DecrRefCount(errMsg); } return result; } code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, &tokensLeft, 1, NULL, NULL); } } /* *---------------------------------------------------------------------- * * TclSubstTokens -- |
︙ | ︙ | |||
2142 2143 2144 2145 2146 2147 2148 | Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ int count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 | Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ int count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ 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* 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 * components, if any. The only thing tricky here is that we go to some * effort to pass Tcl_Obj's through untouched, to avoid string copying and * Tcl_Obj creation if possible, to aid performance and limit shimmering. * * Further optimization opportunities might be to check for the equivalent * 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; const char *append = NULL; int appendByteLength = 0; char utfCharBytes[TCL_UTF_MAX]; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: append = tokenPtr->start; appendByteLength = tokenPtr->size; break; case TCL_TOKEN_BS: 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; 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; /* TIP #280: Transfer line information to nested command */ code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, 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--; appendObj = Tcl_GetObjResult(interp); break; } case TCL_TOKEN_VARIABLE: { Tcl_Obj *arrayIndex = NULL; Tcl_Obj *varName = NULL; if (tokenPtr->numComponents > 1) { /* * Subst the index part of an array variable reference. */ code = TclSubstTokens(interp, tokenPtr+2, tokenPtr->numComponents - 1, NULL, line, NULL, NULL); arrayIndex = Tcl_GetObjResult(interp); Tcl_IncrRefCount(arrayIndex); } if (code == TCL_OK) { varName = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); |
︙ | ︙ | |||
2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 | } } } if (code != TCL_ERROR) { /* Keep error message in result! */ if (result != NULL) { Tcl_SetObjResult(interp, result); } else { Tcl_ResetResult(interp); } } if (tokensLeftPtr != NULL) { *tokensLeftPtr = count; } | > > > > > > > > > > > > > > > > > > > > | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 | } } } 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); } } if (tokensLeftPtr != NULL) { *tokensLeftPtr = count; } |
︙ | ︙ |
Changes to generic/tclProc.c.
︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004-2006 Miguel Sofer * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004-2006 Miguel Sofer * Copyright (c) 2007 Daniel A. Steffen <[email protected]> * * 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.139.2.6 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Prototypes for static functions in this file |
︙ | ︙ | |||
426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | * means that the same code can not be shared by two procedures that * have a different number of arguments, even if their bodies are * identical. Note that we don't use Tcl_DuplicateObj since we would * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); } /* * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ | > > > > > > > > > > | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | * means that the same code can not be shared by two procedures that * have a different number of arguments, even if their bodies are * identical. Note that we don't use Tcl_DuplicateObj since we would * not want any bytecode internal representation. */ 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); } /* * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ |
︙ | ︙ | |||
2526 2527 2528 2529 2530 2531 2532 | CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ | | | 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 | CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; cfPtr->line = (int *) ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; |
︙ | ︙ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
12 13 14 15 16 17 18 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Miguel Sofer * * 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.160.2.5 2009/08/25 21:01:05 andreas_kupries Exp $ */ #include "tclInt.h" /* * Prototypes for the variable hash key methods. */ |
︙ | ︙ | |||
1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 | if (oldValuePtr == NULL) { varPtr->value.objPtr = newValuePtr; Tcl_IncrRefCount(newValuePtr); } else { if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); TclDecrRefCount(oldValuePtr); oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); } } | > > > > > > > > | 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 | if (oldValuePtr == NULL) { varPtr->value.objPtr = newValuePtr; Tcl_IncrRefCount(newValuePtr); } else { if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); /* * TIP #280. * Ensure that the continuation line data for the string * is not lost and applies to the extended script as well. */ TclContinuationsCopy (varPtr->value.objPtr, oldValuePtr); TclDecrRefCount(oldValuePtr); oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ } Tcl_AppendObjToObj(oldValuePtr, newValuePtr); } } |
︙ | ︙ |
Changes to tests/info.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2006 ActiveState # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2006 ActiveState # # 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.47.2.9 2009/08/25 21:01:05 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # Set up namespaces needed to test operation of "info args", "info body", |
︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 | test info-25.1 {info frame, regular proc} { reduce [bar] } {type source line 1006 file info.test cmd {info frame 0} proc ::bar level 0} rename bar {} # ------------------------------------------------------------------------- | | | | | | | | | | | 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 | test info-25.1 {info frame, regular proc} { reduce [bar] } {type source line 1006 file info.test cmd {info frame 0} proc ::bar level 0} rename bar {} # ------------------------------------------------------------------------- # 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]];# 1019 } set res # 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 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 1019 file info.test cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- # See 24.0 - 24.5 for similar situations, using literal scripts. set body {set flag 0 set a c set res [info frame 0]} ;# line 3! |
︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 | } set res [::foo::bar] namespace delete ::foo join $res \n } -result { type source line 1420 file info.test cmd {info frame 0} proc ::foo::bar level 0 type source line 1421 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 | } set res [::foo::bar] namespace delete ::foo join $res \n } -result { type source line 1420 file info.test cmd {info frame 0} proc ::foo::bar level 0 type source line 1421 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 1439 } } set res [abra] rename abra {} set res } {type source line 1439 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 1450 } set res } {type source line 1450 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 1457 set res } {type source line 1457 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 1464 } set res } {type source line 1464 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 1474 } } set res } {type source line 1474 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 1482 } { type source line 1482 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 1488 } set res [abra] rename abra {} set res } { type source line 1488 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 1499 } } { type source line 1499 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 1508 } } { type source line 1508 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 ; #1516 unset tmp set res } { type source line 1516 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 1534 } } { type source line 1534 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 1543 } } set res } {type source line 1543 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 1555 }] rename abra {} set res } { type source line 1555 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 1567 } } } a ; set res [b] rename a {} rename b {} set res } {type source line 1567 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; # 1580 } \ \t### { info frame 0; # 1581 } \ {[0-9]*} { info frame 0; # 1582 } } set res {} lappend res [reduce [a {key }]] lappend res [reduce [a {1alpha}]] set res "\n[join $res \n]" } { type source line 1580 file info.test cmd {info frame 0} proc ::a level 0 type source line 1582 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] ;# 1594 } \ \t### { } \ {[0-9]*} { } } {type source line 1594 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 1606, 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 1617 file info.test cmd {info frame 0} proc ::a level 0 type source line 1621 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 1636 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} } set res {} lappend res [reduce [a 1]] lappend res [reduce [a 0]] set res "\n[join $res \n]" } { type source line 1645 file info.test cmd {info frame 0} proc ::a level 0 type source line 1646 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 ; #1661 unset tmp set res } set res [a] rename a {} set res } { type source line 1661 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; # 1673 } \ xxx { info frame 0; # 1674 } \ 000 { info frame 0; # 1675 } } set res {} lappend res [reduce [a key]] lappend res [reduce [a 000]] set res "\n[join $res \n]" } { type source line 1673 file info.test cmd {info frame 0} proc ::a level 0 type source line 1675 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 1689 file info.test cmd {info frame 0} proc ::a level 0 type source line 1693 file info.test cmd {info frame 0} proc ::a level 0} # ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests return |