Tcl Source Code

Check-in [40f723e2c0]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment: * generic/tclBasic.c: Extended the existing TIP #280 system (info * generic/tclCmdAH.c: frame), added the ability to track the * generic/tclCompCmds.c: absolute location of literal procedure * generic/tclCompile.c: arguments, and making this information * generic/tclCompile.h: available to uplevel, eval, and * generic/tclInterp.c: siblings. This allows proper tracking of * generic/tclInt.h: absolute location through custom (Tcl-coded) * generic/tclNamesp.c: control structures based on uplevel, etc. * generic/tclProc.c:
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-5-branch
Files: files | file ages | folders
SHA1: 40f723e2c02d71c7eaa2d914ed2d6d471a6f2f04
User & Date: andreas_kupries 2008-07-21 19:38:09
Context
2008-07-21
19:44
Undo local changes which did not belong in the last commit. check-in: 118be23b5a user: andreas_kupries tags: core-8-5-branch
19:38
* generic/tclBasic.c: Extended the existing TIP #280 system (info * generic/tclCmdAH.c: frame), a... check-in: 40f723e2c0 user: andreas_kupries tags: core-8-5-branch
14:56
Backported fix for bug #2015723 check-in: 295579a555 user: patthoyts tags: core-8-5-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.













1
2
3
4
5
6
7












2008-07-21  Pat Thoyts  <[email protected]>

	* generic/tclFCmd.c: Inodes on windows are unreliable [Bug 2015723]

2008-07-20  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (SetDictFromAny): Make the list->dict
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
2008-07-21  Andreas Kupries <[email protected]>

	* generic/tclBasic.c: Extended the existing TIP #280 system (info
	* generic/tclCmdAH.c: frame), added the ability to track the
	* generic/tclCompCmds.c: absolute location of literal procedure
	* generic/tclCompile.c: arguments, and making this information
	* generic/tclCompile.h: available to uplevel, eval, and
	* generic/tclInterp.c: siblings. This allows proper tracking of
	* generic/tclInt.h: absolute location through custom (Tcl-coded)
	* generic/tclNamesp.c: control structures based on uplevel, etc.
	* generic/tclProc.c:

2008-07-21  Pat Thoyts  <[email protected]>

	* generic/tclFCmd.c: Inodes on windows are unreliable [Bug 2015723]

2008-07-20  Donal K. Fellows  <[email protected]>

	* generic/tclDictObj.c (SetDictFromAny): Make the list->dict

Changes to generic/tclBasic.c.

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 2008/03/14 19:53:10 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <limits.h>
#include <math.h>







|







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.1 2008/07/21 19:38:13 andreas_kupries Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"
#include <float.h>
#include <limits.h>
#include <math.h>
440
441
442
443
444
445
446

447
448

449
450
451
452
453
454
455
     * TIP #280 - Initialize the arrays used to extend the ByteCode and
     * Proc structures.
     */

    iPtr->cmdFramePtr = NULL;
    iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));

    Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);


    iPtr->activeVarTracePtr = NULL;

    iPtr->returnOpts = NULL;
    iPtr->errorInfo = NULL;
    TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
    Tcl_IncrRefCount(iPtr->eiVar);







>


>







440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
     * TIP #280 - Initialize the arrays used to extend the ByteCode and
     * Proc structures.
     */

    iPtr->cmdFramePtr = NULL;
    iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    iPtr->lineLAPtr = (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);

    iPtr->activeVarTracePtr = NULL;

    iPtr->returnOpts = NULL;
    iPtr->errorInfo = NULL;
    TclNewLiteralStringObj(iPtr->eiVar, "::errorInfo");
    Tcl_IncrRefCount(iPtr->eiVar);
1407
1408
1409
1410
1411
1412
1413




















1414
1415
1416
1417
1418
1419
1420

	    ckfree((char *) eclPtr);
	    Tcl_DeleteHashEntry(hPtr);
	}
	Tcl_DeleteHashTable(iPtr->lineBCPtr);
	ckfree((char *) iPtr->lineBCPtr);
	iPtr->lineBCPtr = NULL;




















    }

    Tcl_DeleteHashTable(&iPtr->varTraces);
    Tcl_DeleteHashTable(&iPtr->varSearches);

    ckfree((char *) iPtr);
}







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442

	    ckfree((char *) eclPtr);
	    Tcl_DeleteHashEntry(hPtr);
	}
	Tcl_DeleteHashTable(iPtr->lineBCPtr);
	ckfree((char *) iPtr->lineBCPtr);
	iPtr->lineBCPtr = NULL;

	/*
	 * Location stack for uplevel/eval/... scripts which were passed
	 * through proc arguments. Actually we track all arguments as we
	 * don't, cannot know which arguments will be used as scripts and
	 * which won't.
	 */

	if (iPtr->lineLAPtr->numEntries) {
	    /*
	     * When the interp goes away we have nothing on the stack, so
	     * there are no arguments, so this table has to be empty.
	     */

	    Tcl_Panic ("Argument location tracking table not empty");
	}

	Tcl_DeleteHashTable (iPtr->lineLAPtr);
	ckfree((char*) iPtr->lineLAPtr);
	iPtr->lineLAPtr = NULL;
    }

    Tcl_DeleteHashTable(&iPtr->varTraces);
    Tcl_DeleteHashTable(&iPtr->varSearches);

    ckfree((char *) iPtr);
}
4287
4288
4289
4290
4291
4292
4293

4294
4295
4296
4297
4298
4299

4300
4301
4302
4303
4304
4305
4306
		    parsePtr->commandStart + parsePtr->commandSize - 1) {
		eeFramePtr->cmd.str.len--;
	    }

	    eeFramePtr->nline = objectsUsed;
	    eeFramePtr->line = lines;


	    iPtr->cmdFramePtr = eeFramePtr;
	    iPtr->numLevels++;
	    code = TclEvalObjvInternal(interp, objectsUsed, objv,
		    parsePtr->commandStart, parsePtr->commandSize, 0);
	    iPtr->numLevels--;
	    iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;


	    eeFramePtr->line = NULL;
	    eeFramePtr->nline = 0;

	    if (code != TCL_OK) {
		goto error;
	    }







>






>







4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
		    parsePtr->commandStart + parsePtr->commandSize - 1) {
		eeFramePtr->cmd.str.len--;
	    }

	    eeFramePtr->nline = objectsUsed;
	    eeFramePtr->line = lines;

	    TclArgumentEnter (interp, objv, objectsUsed, eeFramePtr);
	    iPtr->cmdFramePtr = eeFramePtr;
	    iPtr->numLevels++;
	    code = TclEvalObjvInternal(interp, objectsUsed, objv,
		    parsePtr->commandStart, parsePtr->commandSize, 0);
	    iPtr->numLevels--;
	    iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
	    TclArgumentRelease (interp, objv, objectsUsed);

	    eeFramePtr->line = NULL;
	    eeFramePtr->nline = 0;

	    if (code != TCL_OK) {
		goto error;
	    }
4439
4440
4441
4442
4443
4444
4445









































































































































































































4446
4447
4448
4449
4450
4451
4452

    for (p = start; p < end; p++) {
	if (*p == '\n') {
	    (*line)++;
	}
    }
}










































































































































































































/*
 *----------------------------------------------------------------------
 *
 * Tcl_Eval --
 *
 *	Execute a Tcl command in a string. This function executes the script







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
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
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
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677

    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
 * space/time efficient.
 */

/*
 *----------------------------------------------------------------------
 *
 * TclArgumentEnter --
 *
 *	This procedure is a helper for the TIP #280 uplevel extension.
 *	It enters location references for the arguments of a command to be
 *	invoked. Only the first entry has the actual data, further entries
 *	simply count the usage up.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May allocate memory.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclArgumentEnter(interp,objv,objc,cfPtr)
     Tcl_Interp* interp;
     Tcl_Obj**   objv;
     int         objc;
     CmdFrame*   cfPtr;
{
    Interp* iPtr = (Interp*) interp;
    int new, i;
    Tcl_HashEntry* hPtr;
    CFWord* cfwPtr;

    for (i=1; i < objc; i++) {
	/*
	 * Ignore argument words without line information (= dynamic).  If
	 * they are variables they may have location information associated
	 * with that, either through globally recorded 'set' invokations, or
	 * literals in bytecode. Eitehr way there is no need to record
	 * something here.
	 */

	if (cfPtr->line [i] < 0) continue;
	hPtr = Tcl_CreateHashEntry (iPtr->lineLAPtr, (char*) objv[i], &new);
	if (new) {
           /*
	    * The word is not on the stack yet, remember the current location
	    * and initialize references.
            */
           cfwPtr = (CFWord*) ckalloc (sizeof (CFWord));
           cfwPtr->framePtr = cfPtr;
           cfwPtr->word     = i;
           cfwPtr->refCount = 1;
           Tcl_SetHashValue (hPtr, cfwPtr);
	} else {
           /*
	    * The word is already on the stack, its current location is not
            * relevant. Just remember the reference to prevent early removal.
            */
           cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
           cfwPtr->refCount ++;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclArgumentRelease --
 *
 *	This procedure is a helper for the TIP #280 uplevel extension.
 *	It removes the location references for the arguments of a command
 *	just done. Usage is counted down, the data is removed only when
 *	no user is left over.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May release memory.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclArgumentRelease(interp,objv,objc)
     Tcl_Interp* interp;
     Tcl_Obj**   objv;
     int         objc;
{
    Interp*        iPtr = (Interp*) interp;
    Tcl_HashEntry* hPtr;
    CFWord*        cfwPtr;
    int i;

    for (i=1; i < objc; i++) {
       hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) objv[i]);

       if (!hPtr) { continue; }
       cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);

       cfwPtr->refCount --;
       if (cfwPtr->refCount > 0) { continue; }

       ckfree ((char*) cfwPtr);
       Tcl_DeleteHashEntry (hPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclArgumentGet --
 *
 *	This procedure is a helper for the TIP #280 uplevel extension.
 *	It find the location references for a Tcl_Obj, if any.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Writes found location information into the result arguments.
 *
 * TIP #280
 *----------------------------------------------------------------------
 */

void
TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
     Tcl_Interp* interp;
     Tcl_Obj*    obj;
     CmdFrame**  cfPtrPtr;
     int*        wordPtr;
{
    Interp*        iPtr = (Interp*) interp;
    Tcl_HashEntry* hPtr;
    CmdFrame*      framePtr;

    /*
     * First look for location information recorded in the argument
     * stack. That is nearest.
     */

    hPtr = Tcl_FindHashEntry (iPtr->lineLAPtr, (char *) obj);
    if (hPtr) {
	CFWord* cfwPtr = (CFWord*) Tcl_GetHashValue (hPtr);
	*wordPtr  = cfwPtr->word;
	*cfPtrPtr = cfwPtr->framePtr;
	return;
    }

    /*
     * Check if the Tcl_Obj has location information as a bytecode literal. We
     * have to scan the stack up and check all bytecode frames for a possible
     * definition.
     */

    for (framePtr = iPtr->cmdFramePtr;
	 framePtr;
	 framePtr = framePtr->nextPtr) {
	const ByteCode* codePtr;
	Tcl_HashEntry*  hePtr;

	if (framePtr->type != TCL_LOCATION_BC) continue;

	codePtr = framePtr->data.tebc.codePtr;
	hePtr   = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);

	if (hePtr) {
	    ExtCmdLoc*    eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
	    Tcl_HashEntry *hlPtr = Tcl_FindHashEntry (&eclPtr->litIndex, (char *) obj);

	    if (hlPtr) {
		/*
		 * Convert from the current invoker CmdFrame to a CmdFrame
		 * refering to the actual word location. We are directly
		 * manipulating the relevant command frame in the frame stack.
		 * That is no problem because TEBC is already setting the pc
		 * for each invokation, so moving it somewhere will not affect
		 * the following commands.
		 */

		ExtIndex* eiPtr = (ExtIndex*) Tcl_GetHashValue (hlPtr);

		framePtr->data.tebc.pc = codePtr->codeStart + eiPtr->pc;
		*cfPtrPtr = framePtr;
		*wordPtr  = eiPtr->word;
	    }
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Eval --
 *
 *	Execute a Tcl command in a string. This function executes the script
4682
4683
4684
4685
4686
4687
4688

















4689


4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
	     * non-'source' context we don't have to try tracking lines.
	     *
	     * First see if the word exists and is a literal. If not we go
	     * through the easy dynamic branch. No need to perform more
	     * complex invokations.
	     */


















	    if ((invoker->nline <= word) || (invoker->line[word] < 0)) {


		/*
		 * Dynamic script, or dynamic context, force our own
		 * context.
		 */

		script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
		result = Tcl_EvalEx(interp, script, numSrcBytes, flags);

	    } else {
		/*
		 * Try to get an absolute context for the evaluation.
		 */

		int pc = 0;
		CmdFrame *ctxPtr = (CmdFrame *)
			TclStackAlloc(interp, sizeof(CmdFrame));

		*ctxPtr = *invoker;
		if (invoker->type == TCL_LOCATION_BC) {
		    /*
		     * Note: Type BC => ctxPtr->data.eval.path is not used.
		     * ctxPtr->data.tebc.codePtr is used instead.
		     */

		    TclGetSrcInfoForPc(ctxPtr);
		    pc = 1;
		}

		if (ctxPtr->type == TCL_LOCATION_SOURCE) {
		    /*
		     * Absolute context to reuse.
		     */

		    iPtr->invokeCmdFramePtr = ctxPtr;
		    iPtr->evalFlags |= TCL_EVAL_CTX;

		    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
		    result = TclEvalEx(interp, script, numSrcBytes, flags,
			    ctxPtr->line[word]);

		    if (pc) {
			/*
			 * Death of SrcInfo reference.
			 */

			Tcl_DecrRefCount(ctxPtr->data.eval.path);
		    }
		} else {
		    /*
		     * Dynamic context or script, easier to make our own as
		     * well.
		     */

		    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
		    result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
		}

		TclStackFree(interp, ctxPtr);
	    }
	}
    } 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.







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>





<




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|

|
|

<
|
|

|
|
|
|

|
|
<
<
<
<
<
|
<
<
<
<
|
<







4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938

4939
4940
4941
4942




















4943
4944
4945
4946
4947
4948

4949
4950
4951
4952
4953
4954
4955
4956
4957
4958





4959




4960

4961
4962
4963
4964
4965
4966
4967
	     * non-'source' context we don't have to try tracking lines.
	     *
	     * First see if the word exists and is a literal. If not we go
	     * through the easy dynamic branch. No need to perform more
	     * complex invokations.
	     */

	    int pc = 0;
	    CmdFrame *ctxPtr = (CmdFrame *)
		TclStackAlloc(interp, sizeof(CmdFrame));

	    *ctxPtr = *invoker;
	    if (invoker->type == TCL_LOCATION_BC) {
		/*
		 * Note: Type BC => ctxPtr->data.eval.path is not used.
		 * ctxPtr->data.tebc.codePtr is used instead.
		 */

		TclGetSrcInfoForPc(ctxPtr);
		pc = 1;
	    }

	    script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);

	    if ((ctxPtr->nline <= word) ||
		(ctxPtr->line[word] < 0) ||
		(ctxPtr->type != TCL_LOCATION_SOURCE)) {
		/*
		 * Dynamic script, or dynamic context, force our own
		 * context.
		 */


		result = Tcl_EvalEx(interp, script, numSrcBytes, flags);

	    } else {
		/*




















		 * Absolute context to reuse.
		 */

		iPtr->invokeCmdFramePtr = ctxPtr;
		iPtr->evalFlags |= TCL_EVAL_CTX;


		result = TclEvalEx(interp, script, numSrcBytes, flags,
				   ctxPtr->line[word]);

		if (pc) {
		    /*
		     * Death of SrcInfo reference.
		     */

		    Tcl_DecrRefCount(ctxPtr->data.eval.path);
		}





	    }




	    TclStackFree(interp, ctxPtr);

	}
    } 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/tclCmdAH.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters A to H.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.93 2008/03/14 16:07:23 dgp Exp $
 */

#include "tclInt.h"
#include <locale.h>

/*
 * Prototypes for local procedures defined in this file:












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclCmdAH.c --
 *
 *	This file contains the top-level command routines for most of the Tcl
 *	built-in commands whose names begin with the letters A to H.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdAH.c,v 1.93.2.1 2008/07/21 19:38:17 andreas_kupries Exp $
 */

#include "tclInt.h"
#include <locale.h>

/*
 * Prototypes for local procedures defined in this file:
652
653
654
655
656
657
658
659
660
661




662
663
664
665
666
667
668
669
670
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	/*
	 * TIP #280. Make invoking context available to eval'd script.
	 */





	result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
		iPtr->cmdFramePtr, 1);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */








|


>
>
>
>

|







652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
	return TCL_ERROR;
    }

    if (objc == 2) {
	/*
	 * TIP #280. Make argument location available to eval'd script.
	 */

	CmdFrame* invoker = iPtr->cmdFramePtr;
	int word          = 1;
	TclArgumentGet (interp, objv[1], &invoker, &word);

	result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
		invoker, word);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

Changes to generic/tclCompile.c.

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.1 2008/05/16 14:27:30 msofer Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.













|







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.2 2008/07/21 19:38:17 andreas_kupries Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Table of all AuxData types.
798
799
800
801
802
803
804


805
806
807
808
809
810
811
812
813
814
815
816









817
818
819
820
821
822
823

    if (iPtr) {
	Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
		(char *) codePtr);
	if (hePtr) {
	    ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
	    int i;



	    if (eclPtr->type == TCL_LOCATION_SOURCE) {
		Tcl_DecrRefCount(eclPtr->path);
	    }
	    for (i=0 ; i<eclPtr->nuloc ; i++) {
		ckfree((char *) eclPtr->loc[i].line);
	    }

	    if (eclPtr->loc != NULL) {
		ckfree((char *) eclPtr->loc);
	    }










	    ckfree((char *) eclPtr);
	    Tcl_DeleteHashEntry(hePtr);
	}
    }

    if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
	TclFreeLocalCache(interp, codePtr->localCachePtr);







>
>












>
>
>
>
>
>
>
>
>







798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834

    if (iPtr) {
	Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
		(char *) codePtr);
	if (hePtr) {
	    ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
	    int i;
	    Tcl_HashSearch hSearch;
	    Tcl_HashEntry *hlPtr;

	    if (eclPtr->type == TCL_LOCATION_SOURCE) {
		Tcl_DecrRefCount(eclPtr->path);
	    }
	    for (i=0 ; i<eclPtr->nuloc ; i++) {
		ckfree((char *) eclPtr->loc[i].line);
	    }

	    if (eclPtr->loc != NULL) {
		ckfree((char *) eclPtr->loc);
	    }

	    /* Release index of literals as well. */
	    for (hlPtr = Tcl_FirstHashEntry(&eclPtr->litIndex, &hSearch);
		 hlPtr != NULL;
		 hlPtr = Tcl_NextHashEntry(&hSearch)) {
		ExtIndex* eiPtr = (ExtIndex*) Tcl_GetHashValue (hlPtr);
		ckfree((char*) eiPtr);
		Tcl_DeleteHashEntry (hlPtr);
	    }
	    Tcl_DeleteHashTable (&eclPtr->litIndex);
	    ckfree((char *) eclPtr);
	    Tcl_DeleteHashEntry(hePtr);
	}
    }

    if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
	TclFreeLocalCache(interp, codePtr->localCachePtr);
899
900
901
902
903
904
905

906
907
908
909
910
911
912
     */

    envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc));
    envPtr->extCmdMapPtr->loc = NULL;
    envPtr->extCmdMapPtr->nloc = 0;
    envPtr->extCmdMapPtr->nuloc = 0;
    envPtr->extCmdMapPtr->path = NULL;


    if (invoker == NULL) {
        /*
	 * Initialize the compiler for relative counting.
	 */

	envPtr->line = 1;







>







910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
     */

    envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc));
    envPtr->extCmdMapPtr->loc = NULL;
    envPtr->extCmdMapPtr->nloc = 0;
    envPtr->extCmdMapPtr->nuloc = 0;
    envPtr->extCmdMapPtr->path = NULL;
    Tcl_InitHashTable(&envPtr->extCmdMapPtr->litIndex, TCL_ONE_WORD_KEYS);

    if (invoker == NULL) {
        /*
	 * Initialize the compiler for relative counting.
	 */

	envPtr->line = 1;
1438
1439
1440
1441
1442
1443
1444








1445
1446







1447
1448
1449
1450
1451
1452
1453
			 * avoid shimmering between bytecode and cmdName
			 * representations [Bug 458361]
			 */

			TclHideLiteral(interp, envPtr, objIndex);
		    }
		} else {








		    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.







>
>
>
>
>
>
>
>


>
>
>
>
>
>
>







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
			 * avoid shimmering between bytecode and cmdName
			 * representations [Bug 458361]
			 */

			TclHideLiteral(interp, envPtr, objIndex);
		    }
		} else {
		    /*
		     * Simple argument word of a command. We reach this if and
		     * only if the command word was not compiled for whatever
		     * 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 (eclPtr->type == TCL_LOCATION_SOURCE) {
			TclEnterCmdWordIndex (eclPtr,
					      envPtr->literalArrayPtr[objIndex].objPtr,
					      envPtr->codeNext - envPtr->codeStart,
					      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.
2407
2408
2409
2410
2411
2412
2413


















2414
2415
2416
2417
2418
2419
2420
	ePtr->line[wordIdx] = wordLine;
	last = tokenPtr->start;
    }

    *wlines = wwlines;
    eclPtr->nuloc ++;
}



















/*
 *----------------------------------------------------------------------
 *
 * TclCreateExceptRange --
 *
 *	Procedure that allocates and initializes a new ExceptionRange







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
	ePtr->line[wordIdx] = wordLine;
	last = tokenPtr->start;
    }

    *wlines = wwlines;
    eclPtr->nuloc ++;
}

void
TclEnterCmdWordIndex (eclPtr, obj, pc, word)
     ExtCmdLoc *eclPtr;
     Tcl_Obj*   obj;
     int        pc;
     int        word;
{
    int       new;
    ExtIndex* eiPtr = (ExtIndex*) ckalloc (sizeof (ExtIndex));

    eiPtr->pc   = pc;
    eiPtr->word = word;

    Tcl_SetHashValue (Tcl_CreateHashEntry (&eclPtr->litIndex,
					   (char*) obj, &new),
		      eiPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateExceptRange --
 *
 *	Procedure that allocates and initializes a new ExceptionRange

Changes to generic/tclCompile.h.

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 2008/02/26 20:28:59 jenglish Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#include "tclInt.h"












|







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.1 2008/07/21 19:38:18 andreas_kupries Exp $
 */

#ifndef _TCLCOMPILATION
#define _TCLCOMPILATION 1

#include "tclInt.h"

125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143

144








145
146
147
148
149
150
151
 * through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
 * Also recorded is information coming from the context, i.e. type of the
 * frame and associated information, like the path of a sourced file.
 */

typedef struct ECL {
    int srcOffset;		/* Command location to find the entry. */
    int nline;
    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). */
    int nloc;			/* Number of allocated entries in 'loc'. */
    int nuloc;			/* Number of used entries in 'loc'. */

} ExtCmdLoc;









/*
 * CompileProcs need the ability to record information during compilation that
 * can be used by bytecode instructions during execution. The AuxData
 * structure provides this "auxiliary data" mechanism. An arbitrary number of
 * these structures can be stored in the ByteCode record (during compilation
 * they are stored in a CompileEnv structure). Each AuxData record holds one







|











>

>
>
>
>
>
>
>
>







125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
 * through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
 * Also recorded is information coming from the context, i.e. type of the
 * frame and associated information, like the path of a sourced file.
 */

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). */
    int nloc;			/* Number of allocated entries in 'loc'. */
    int nuloc;			/* Number of used entries in 'loc'. */
    Tcl_HashTable litIndex;     /* HashValue is ExtIndex* */
} ExtCmdLoc;

typedef struct ExtIndex {
  int pc;   /* Instruction pointer of a command in ExtCmdLoc.loc[.] */
  int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */
} ExtIndex;

EXTERN void TclEnterCmdWordIndex (ExtCmdLoc *eclPtr, Tcl_Obj* obj,
				  int pc, int word);

/*
 * CompileProcs need the ability to record information during compilation that
 * can be used by bytecode instructions during execution. The AuxData
 * structure provides this "auxiliary data" mechanism. An arbitrary number of
 * these structures can be stored in the ByteCode record (during compilation
 * they are stored in a CompileEnv structure). Each AuxData record holds one

Changes to generic/tclInt.h.

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.1 2008/03/31 17:21:14 dgp Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options







|







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.2 2008/07/21 19:38:18 andreas_kupries Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Some numerics configuration options
1137
1138
1139
1140
1141
1142
1143






1144
1145
1146
1147
1148
1149
1150
	    const char *cmd;	/* The executed command, if possible */
	    int len;		/* And its length */
	} str;
	Tcl_Obj *listPtr;	/* Tcl_EvalObjEx, cmd list */
    } cmd;
} CmdFrame;







/*
 * 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







>
>
>
>
>
>







1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
	    const char *cmd;	/* The executed command, if possible */
	    int len;		/* And its length */
	} str;
	Tcl_Obj *listPtr;	/* Tcl_EvalObjEx, cmd list */
    } cmd;
} CmdFrame;

typedef struct CFWord {
    CmdFrame* framePtr;  /* CmdFrame to acess */
    int       word;      /* Index of the word in the command */
    int       refCount;  /* #times the word is on the stack */
} CFWord;

/*
 * 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
1828
1829
1830
1831
1832
1833
1834
1835

1836
1837
1838
1839














1840
1841
1842
1843
1844
1845
1846
				 * NULL when the byte code compiler is not
				 * active */
    int invokeWord;		/* Index of the word in the command which
				 * is getting compiled. */
    Tcl_HashTable *linePBodyPtr;/* This table remembers for each statically
				 * defined procedure the location information
				 * for its body. It is keyed by the address of
				 * the Proc structure for a procedure. */

    Tcl_HashTable *lineBCPtr;	/* This table remembers for each ByteCode
				 * object the location information for its
				 * body. It is keyed by the address of the
				 * Proc structure for a procedure. */














    /*
     * TIP #268. The currently active selection mode, i.e. the package require
     * preferences.
     */

    int packagePrefer;		/* Current package selection mode. */








|
>



|
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
				 * NULL when the byte code compiler is not
				 * active */
    int invokeWord;		/* Index of the word in the command which
				 * is getting compiled. */
    Tcl_HashTable *linePBodyPtr;/* This table remembers for each statically
				 * defined procedure the location information
				 * for its body. It is keyed by the address of
				 * the Proc structure for a procedure. The
				 * values are "struct CmdFrame*". */
    Tcl_HashTable *lineBCPtr;	/* This table remembers for each ByteCode
				 * object the location information for its
				 * body. It is keyed by the address of the
				 * Proc structure for a procedure. The values
				 * are "struct ExtCmdLoc*" (See tclCompile.h) */
    Tcl_HashTable* lineLAPtr;   /* This table remembers for each argument of a
				 * command on the execution stack the index of
				 * the argument in the command, and the
				 * location data of the command. It is keyed
				 * by the address of the Tcl_Obj containing
				 * the argument. The values are "struct
				 * 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. */

2426
2427
2428
2429
2430
2431
2432






2433
2434
2435
2436
2437
2438
2439
 *----------------------------------------------------------------
 * 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 int	TclArraySet(Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double	TclBignumToDouble(mp_int *bignum);
MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
			    int strLen, const unsigned char *pattern,
			    int ptnLen, int flags);
MODULE_SCOPE double	TclCeil(mp_int *a);







>
>
>
>
>
>







2447
2448
2449
2450
2451
2452
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,
			    CmdFrame** cfPtrPtr, int* wordPtr);
MODULE_SCOPE int	TclArraySet(Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double	TclBignumToDouble(mp_int *bignum);
MODULE_SCOPE int	TclByteArrayMatch(const unsigned char *string,
			    int strLen, const unsigned char *pattern,
			    int ptnLen, int flags);
MODULE_SCOPE double	TclCeil(mp_int *a);

Changes to generic/tclInterp.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclInterp.c --
 *
 *	This file implements the "interp" command which allows creation and
 *	manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 2004 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: tclInterp.c,v 1.83.2.1 2008/06/20 19:23:25 dgp Exp $
 */

#include "tclInt.h"

/*
 * A pointer to a string that holds an initialization script that if non-NULL
 * is evaluated in Tcl_Init() prior to the built-in initialization script












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
/*
 * tclInterp.c --
 *
 *	This file implements the "interp" command which allows creation and
 *	manipulation of Tcl interpreters from within Tcl scripts.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 * Copyright (c) 2004 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: tclInterp.c,v 1.83.2.2 2008/07/21 19:38:19 andreas_kupries Exp $
 */

#include "tclInt.h"

/*
 * A pointer to a string that holds an initialization script that if non-NULL
 * is evaluated in Tcl_Init() prior to the built-in initialization script
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478




2479
2480
2481
2482
2483
2484
2485
2486
    Tcl_Obj *objPtr;

    Tcl_Preserve(slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (objc == 1) {
	/*
	 * TIP #280: Make invoker available to eval'd script.
	 */

        Interp *iPtr = (Interp *) interp;




	result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr, 0);
    } else {
	objPtr = Tcl_ConcatObj(objc, objv);
	Tcl_IncrRefCount(objPtr);
	result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
	Tcl_DecrRefCount(objPtr);
    }
    TclTransferResult(slaveInterp, result, interp);







|



>
>
>
>
|







2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
    Tcl_Obj *objPtr;

    Tcl_Preserve(slaveInterp);
    Tcl_AllowExceptions(slaveInterp);

    if (objc == 1) {
	/*
	 * TIP #280: Make actual argument location available to eval'd script.
	 */

        Interp *iPtr = (Interp *) interp;
	CmdFrame* invoker = iPtr->cmdFramePtr;
	int word          = 0;

	TclArgumentGet (interp, objv[0], &invoker, &word);
	result = TclEvalObjEx(slaveInterp, objv[0], 0, invoker, word);
    } else {
	objPtr = Tcl_ConcatObj(objc, objv);
	Tcl_IncrRefCount(objPtr);
	result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
	Tcl_DecrRefCount(objPtr);
    }
    TclTransferResult(slaveInterp, result, interp);

Changes to generic/tclNamesp.c.

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [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: tclNamesp.c,v 1.162.2.2 2008/05/22 15:25:54 dgp Exp $
 */

#include "tclInt.h"

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.







|







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
 *   Michael J. McLennan
 *   Bell Labs Innovations for Lucent Technologies
 *   [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: tclNamesp.c,v 1.162.2.3 2008/07/21 19:38:19 andreas_kupries Exp $
 */

#include "tclInt.h"

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285


3286

3287
3288
3289
3290
3291
3292
3293
3294
    }

    framePtr->objc = objc;
    framePtr->objv = objv;

    if (objc == 4) {
	/*
	 * TIP #280: Make invoker available to eval'd script.
	 */

	Interp *iPtr = (Interp *) interp;




	result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr, 3);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */








|


|
>
>

>
|







3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
    }

    framePtr->objc = objc;
    framePtr->objv = objv;

    if (objc == 4) {
	/*
	 * TIP #280: Make actual argument location available to eval'd script.
	 */

	Interp *iPtr      = (Interp *) interp;
	CmdFrame* invoker = iPtr->cmdFramePtr;
	int word          = 3;

	TclArgumentGet (interp, objv[3], &invoker, &word);
	result = TclEvalObjEx(interp, objv[3], 0, invoker, word);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

Changes to generic/tclProc.c.

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 2007/12/13 15:23:20 dgp Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file







|







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.1 2008/07/21 19:38:19 andreas_kupries Exp $
 */

#include "tclInt.h"
#include "tclCompile.h"

/*
 * Prototypes for static functions in this file
904
905
906
907
908
909
910








911
912
913
914
915
916
917
918
    iPtr->varFramePtr = framePtr;

    /*
     * Execute the residual arguments as a command.
     */

    if (objc == 1) {








	result = Tcl_EvalObjEx(interp, objv[0], TCL_EVAL_DIRECT);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */








>
>
>
>
>
>
>
>
|







904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
    iPtr->varFramePtr = framePtr;

    /*
     * Execute the residual arguments as a command.
     */

    if (objc == 1) {
	/*
	 * TIP #280. Make argument location available to eval'd script
	 */

	CmdFrame* invoker = NULL;
	int word          = 0;

	TclArgumentGet (interp, objv[0], &invoker, &word);
	result = TclEvalObjEx(interp, objv[0], 0, invoker, word);
    } else {
	/*
	 * More than one argument: concatenate them together with spaces
	 * between, then evaluate the result. Tcl_EvalObjEx will delete the
	 * object when it decrements its refcount after eval'ing it.
	 */

Changes to generic/tclVar.c.

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 2008/03/11 17:23:56 msofer Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for the variable hash key methods.
 */







|







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.1 2008/07/21 19:38:20 andreas_kupries Exp $
 */

#include "tclInt.h"

/*
 * Prototypes for the variable hash key methods.
 */
63
64
65
66
67
68
69








70

71
72
73
74
75
76
77
78
79
80
    } else {
	return NULL;
    }
}

#define VarHashFindVar(tablePtr, key) \
    VarHashCreateVar((tablePtr), (key), NULL)










#define VarHashInvalidateEntry(varPtr) \
    ((varPtr)->flags |= VAR_DEAD_HASH)

#define VarHashDeleteEntry(varPtr) \
    Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry))

#define VarHashFirstEntry(tablePtr, searchPtr) \
    Tcl_FirstHashEntry((Tcl_HashTable *) (tablePtr), (searchPtr))

#define VarHashNextEntry(searchPtr) \







>
>
>
>
>
>
>
>
|
>


|







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
    } else {
	return NULL;
    }
}

#define VarHashFindVar(tablePtr, key) \
    VarHashCreateVar((tablePtr), (key), NULL)
#ifdef _AIX
/* Work around AIX cc problem causing crash in TclDeleteVars. Possible
 * optimizer bug. Do _NOT_ inline this function, this re-activates the
 * problem.
 */
static void
VarHashInvalidateEntry(Var* varPtr) {
    varPtr->flags |= VAR_DEAD_HASH;
}
#else
#define VarHashInvalidateEntry(varPtr) \
    ((varPtr)->flags |= VAR_DEAD_HASH)
#endif
#define VarHashDeleteEntry(varPtr) \
    Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry))

#define VarHashFirstEntry(tablePtr, searchPtr) \
    Tcl_FirstHashEntry((Tcl_HashTable *) (tablePtr), (searchPtr))

#define VarHashNextEntry(searchPtr) \

Changes to tools/genStubs.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	interface.
#
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# 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: genStubs.tcl,v 1.22 2007/12/13 15:28:40 dgp Exp $

package require Tcl 8.4

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute












|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# genStubs.tcl --
#
#	This script generates a set of stub files for a given
#	interface.
#
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# 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: genStubs.tcl,v 1.22.2.1 2008/07/21 19:38:21 andreas_kupries Exp $

package require Tcl 8.4

namespace eval genStubs {
    # libraryName --
    #
    #	The name of the entire library.  This value is used to compute
203
204
205
206
207
208
209



210
211
212
213
214
215
216
proc genStubs::rewriteFile {file text} {
    if {![file exists $file]} {
	puts stderr "Cannot find file: $file"
	return
    }
    set in [open ${file} r]
    set out [open ${file}.new w]




    while {![eof $in]} {
	set line [gets $in]
	if {[string match "*!BEGIN!*" $line]} {
	    break
	}
	puts $out $line







>
>
>







203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
proc genStubs::rewriteFile {file text} {
    if {![file exists $file]} {
	puts stderr "Cannot find file: $file"
	return
    }
    set in [open ${file} r]
    set out [open ${file}.new w]

    # Hardwire the genstubs output to Unix eol.
    fconfigure $out -translation lf

    while {![eof $in]} {
	set line [gets $in]
	if {[string match "*!BEGIN!*" $line]} {
	    break
	}
	puts $out $line

Changes to unix/Makefile.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is
# a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.229.2.3 2008/06/26 22:10:24 andreas_kupries Exp $

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#--------------------------------------------------------------------------






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it is
# a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.229.2.4 2008/07/21 19:38:21 andreas_kupries Exp $

VERSION 		= @TCL_VERSION@
MAJOR_VERSION		= @TCL_MAJOR_VERSION@
MINOR_VERSION		= @TCL_MINOR_VERSION@
PATCH_LEVEL		= @TCL_PATCH_LEVEL@

#--------------------------------------------------------------------------
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
	    do \
	    $(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
	    done;
	@if test -f tclConfig.h; then\
	    $(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
	    fi;

Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
	$(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
#	$(SHELL) config.status

clean:
	rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
		errors tclsh tcltest lib.exp Tcl @DTRACE_HDR@
	cd dltest ; $(MAKE) clean







|
|







872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
	    do \
	    $(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
	    done;
	@if test -f tclConfig.h; then\
	    $(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
	    fi;

#Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
#	$(SHELL) config.status
#tclConfig.h: $(UNIX_DIR)/tclConfig.h.in
#	$(SHELL) config.status

clean:
	rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
		errors tclsh tcltest lib.exp Tcl @DTRACE_HDR@
	cd dltest ; $(MAKE) clean

Changes to win/Makefile.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in" then it
# is a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.124 2008/03/12 09:51:39 hobbs Exp $

VERSION = @TCL_VERSION@

#--------------------------------------------------------------------------
# Things you can change to personalize the Makefile for your own site (you can
# make these changes in either Makefile.in or Makefile, but changes to
# Makefile will get lost if you re-run the configuration script).






|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
#
# This file is a Makefile for Tcl.  If it has the name "Makefile.in" then it
# is a template for a Makefile; to generate the actual Makefile, run
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
# RCS: @(#) $Id: Makefile.in,v 1.124.2.1 2008/07/21 19:38:22 andreas_kupries Exp $

VERSION = @TCL_VERSION@

#--------------------------------------------------------------------------
# Things you can change to personalize the Makefile for your own site (you can
# make these changes in either Makefile.in or Makefile, but changes to
# Makefile will get lost if you re-run the configuration script).
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
gdb: binaries
	@echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run
	gdb ./$(TCLSH) --command=gdb.run
	rm gdb.run

depend:

Makefile: $(SRC_DIR)/Makefile.in
	./config.status

cleanhelp:
	$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe

clean: cleanhelp
	$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
	$(RM) $(TCLSH) $(TCLTEST) $(CAT32)







|
|







713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
gdb: binaries
	@echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run
	gdb ./$(TCLSH) --command=gdb.run
	rm gdb.run

depend:

#Makefile: $(SRC_DIR)/Makefile.in
#	./config.status

cleanhelp:
	$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe

clean: cleanhelp
	$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
	$(RM) $(TCLSH) $(TCLTEST) $(CAT32)