Tcl Source Code

Check-in [e01657bdcf]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:
TIP #336 IMPLEMENTATION
* generic/tcl.decls: New routines Tcl_(Get|Set)ErrorLine. * generic/tcl.h: Dropped default access to interp->errorLine. * generic/tclCmdAH.c: Restore it with -DUSE_INTERP_ERRORLINE. * generic/tclCmdMZ.c: Updated callers. * generic/tclDictObj.c: * generic/tclIOUtil.c: * generic/tclNamesp.c: * generic/tclOOBasic.c: * generic/tclOODefinedCmds.c: * generic/tclOOMethod.c: * generic/tclProc.c: * generic/tclResult.c:
* generic/tclDecls.h: make genstubs * generic/tclStubInit.c:
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | potential incompatibility
Files: files | file ages | folders
SHA1: e01657bdcf2de674c508a72af4619599bab4ef5f
User & Date: dgp 2008-12-02 19:40:40
Context
2008-12-02
19:45
note incompa check-in: fd75928630 user: dgp tags: trunk
19:40
TIP #336 IMPLEMENTATION
* generic/tcl.decls: New routines Tcl_(Get|Set)ErrorLine...
check-in: e01657bdcf user: dgp tags: trunk, potential incompatibility
18:23
* generic/tclIO.c (TclFinalizeIOSubsystem): Replaced Alexandre Ferrieux's first patch for [Bug 22... check-in: 0510216fea user: andreas_kupries tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.





















1
2
3
4
5
6
7



















2008-12-02  Andreas Kupries   <[email protected]>

	* generic/tclIO.c (TclFinalizeIOSubsystem): Replaced Alexandre
	Ferrieux's first patch for [Bug 2270477] with a gentler version,
	also supplied by him.

2008-12-01  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
2008-12-02  Don Porter  <[email protected]>

	TIP #336 IMPLEMENTATION

	* generic/tcl.decls:	New routines Tcl_(Get|Set)ErrorLine.
	* generic/tcl.h:	Dropped default access to interp->errorLine.
	* generic/tclCmdAH.c:	Restore it with -DUSE_INTERP_ERRORLINE.
	* generic/tclCmdMZ.c:	Updated callers.
	* generic/tclDictObj.c:
	* generic/tclIOUtil.c:
	* generic/tclNamesp.c:
	* generic/tclOOBasic.c:
	* generic/tclOODefinedCmds.c:
	* generic/tclOOMethod.c:
	* generic/tclProc.c:
	* generic/tclResult.c:

	* generic/tclDecls.h:	make genstubs
	* generic/tclStubInit.c:

2008-12-02  Andreas Kupries   <[email protected]>

	* generic/tclIO.c (TclFinalizeIOSubsystem): Replaced Alexandre
	Ferrieux's first patch for [Bug 2270477] with a gentler version,
	also supplied by him.

2008-12-01  Don Porter  <[email protected]>

Changes to generic/tcl.decls.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
2199
2200
2201
2202
2203
2204
2205








2206
2207
2208
2209
2210
2211
2212
# 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: tcl.decls,v 1.154 2008/11/17 22:15:34 nijtmans Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private
................................................................................
}

# TIP#265 (option parser)
declare 604 generic {
    int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
	    int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
}









##############################################################################

# Define the platform specific public Tcl interface.  These functions are
# only available on the designated platform.

interface tclPlat






|







 







>
>
>
>
>
>
>
>







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
....
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
# 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: tcl.decls,v 1.155 2008/12/02 19:40:40 dgp Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private
................................................................................
}

# TIP#265 (option parser)
declare 604 generic {
    int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable,
	    int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv)
}

# TIP 335
declare 605 generic {
    int Tcl_GetErrorLine(Tcl_Interp *interp)
}
declare 606 generic {
    void Tcl_SetErrorLine(Tcl_Interp *interp, int value)
}

##############################################################################

# Define the platform specific public Tcl interface.  These functions are
# only available on the designated platform.

interface tclPlat

Changes to generic/tcl.h.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
472
473
474
475
476
477
478

479
480
481



482
483
484
485
486
487
488
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 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: tcl.h,v 1.279 2008/11/27 08:23:51 ferrieux Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
				 * of function to invoke to free the result.
				 * Tcl_Eval must free it before executing next
				 * command. */
#else
    char* unused3;
    void (*unused4) (char*);
#endif

    int errorLine;		/* When TCL_ERROR is returned, this gives the
				 * line number within the command where the
				 * error occurred (1 if first line). */



} Tcl_Interp;

typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;






|







 







>



>
>
>







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 by Scriptics Corporation.
 * Copyright (c) 2002 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: tcl.h,v 1.280 2008/12/02 19:40:41 dgp Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
				 * of function to invoke to free the result.
				 * Tcl_Eval must free it before executing next
				 * command. */
#else
    char* unused3;
    void (*unused4) (char*);
#endif
#ifdef USE_INTERP_ERRORLINE
    int errorLine;		/* When TCL_ERROR is returned, this gives the
				 * line number within the command where the
				 * error occurred (1 if first line). */
#else
    int unused5;
#endif
} Tcl_Interp;

typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;

Changes to generic/tclCmdAH.c.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
...
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
....
1890
1891
1892
1893
1894
1895
1896
1897

1898
1899
1900
1901
1902
1903
1904
....
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
 *
 * 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.110 2008/11/29 18:17:20 dkf Exp $
 */

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

/*
 * The state structure used by [foreach]. Note that the actual structure has
................................................................................
  match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (\"%.50s\" arm line %d)",
		    TclGetString(armPtr), interp->errorLine));
	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */
................................................................................
    
    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (rewind || Tcl_LimitExceeded(interp)) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"catch\" body line %d)", interp->errorLine));
	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
................................................................................
EvalCmdErrMsg(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    if (result == TCL_ERROR) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"eval\" body line %d)", interp->errorLine));
    }
    return result;
}


int
Tcl_EvalObjCmd(
................................................................................
    switch (result) {
    case TCL_BREAK:
	result = TCL_OK;
    case TCL_OK:
	Tcl_ResetResult(interp);
	break;
    case TCL_ERROR:
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(msg, interp->errorLine));

    }
    return result;
}

static int
ForNextCallback(
    ClientData data[],
................................................................................
    case TCL_OK:
	break;
    case TCL_BREAK:
	result = TCL_OK;
	goto done;
    case TCL_ERROR:
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"foreach\" body line %d)", interp->errorLine));
    default:
	goto done;
    }

    /*
     * Test if there is work still to be done. If so, do the next round of
     * variable assignments, reschedule ourselves and run the body again.






|







 







|







 







|







 







|







 







|
>







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
...
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
...
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
....
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
....
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
 *
 * 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.111 2008/12/02 19:40:41 dgp Exp $
 */

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

/*
 * The state structure used by [foreach]. Note that the actual structure has
................................................................................
  match:
    if (body != -1) {
	armPtr = caseObjv[body - 1];
	result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
	if (result == TCL_ERROR) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (\"%.50s\" arm line %d)",
		    TclGetString(armPtr), Tcl_GetErrorLine(interp)));
	}
	return result;
    }

    /*
     * Nothing matched: return nothing.
     */
................................................................................
    
    /*
     * We disable catch in interpreters where the limit has been exceeded.
     */

    if (rewind || Tcl_LimitExceeded(interp)) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"catch\" body line %d)", Tcl_GetErrorLine(interp)));
	return TCL_ERROR;
    }

    if (objc >= 3) {
	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
		Tcl_GetObjResult(interp), 0)) {
	    Tcl_ResetResult(interp);
................................................................................
EvalCmdErrMsg(
    ClientData data[],
    Tcl_Interp *interp,
    int result)
{
    if (result == TCL_ERROR) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"eval\" body line %d)", Tcl_GetErrorLine(interp)));
    }
    return result;
}


int
Tcl_EvalObjCmd(
................................................................................
    switch (result) {
    case TCL_BREAK:
	result = TCL_OK;
    case TCL_OK:
	Tcl_ResetResult(interp);
	break;
    case TCL_ERROR:
	Tcl_AppendObjToErrorInfo(interp,
		Tcl_ObjPrintf(msg, Tcl_GetErrorLine(interp)));
    }
    return result;
}

static int
ForNextCallback(
    ClientData data[],
................................................................................
    case TCL_OK:
	break;
    case TCL_BREAK:
	result = TCL_OK;
	goto done;
    case TCL_ERROR:
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"foreach\" body line %d)", Tcl_GetErrorLine(interp)));
    default:
	goto done;
    }

    /*
     * Test if there is work still to be done. If so, do the next round of
     * variable assignments, reschedule ourselves and run the body again.

Changes to generic/tclCmdMZ.c.

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
....
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
 * 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.171 2008/10/14 22:37:53 nijtmans Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

static int		UniCharIsAscii(int character);

................................................................................
    if (result == TCL_ERROR) {
	int limit = 50;
	int overflow = (patternLength > limit);

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"%.*s%s\" arm line %d)",
		(overflow ? limit : patternLength), pattern,
		(overflow ? "..." : ""), interp->errorLine));
    }
    TclStackFree(interp, ctxPtr);
    return result;
}
 
/*
 *----------------------------------------------------------------------






|







 







|







11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
....
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
 * 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.172 2008/12/02 19:40:41 dgp Exp $
 */

#include "tclInt.h"
#include "tclRegexp.h"

static int		UniCharIsAscii(int character);

................................................................................
    if (result == TCL_ERROR) {
	int limit = 50;
	int overflow = (patternLength > limit);

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"%.*s%s\" arm line %d)",
		(overflow ? limit : patternLength), pattern,
		(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
    }
    TclStackFree(interp, ctxPtr);
    return result;
}
 
/*
 *----------------------------------------------------------------------

Changes to generic/tclDecls.h.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
3653
3654
3655
3656
3657
3658
3659










3660
3661
3662
3663
3664
3665
3666
....
4317
4318
4319
4320
4321
4322
4323


4324
4325
4326
4327
4328
4329
4330
....
6809
6810
6811
6812
6813
6814
6815








6816
6817
6818
6819
6820
6821
6822
6823
6824
6825
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.156 2008/11/17 22:15:34 nijtmans Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
#ifndef Tcl_ParseArgsObjv_TCL_DECLARED
#define Tcl_ParseArgsObjv_TCL_DECLARED
/* 604 */
EXTERN int		Tcl_ParseArgsObjv (Tcl_Interp * interp,
				const Tcl_ArgvInfo * argTable, int * objcPtr,
				Tcl_Obj *const * objv, Tcl_Obj *** remObjv);
#endif











typedef struct TclStubHooks {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

................................................................................
    Tcl_WideInt (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf * statPtr); /* 598 */
    Tcl_WideUInt (*tcl_GetSizeFromStat) (const Tcl_StatBuf * statPtr); /* 599 */
    Tcl_WideUInt (*tcl_GetBlocksFromStat) (const Tcl_StatBuf * statPtr); /* 600 */
    unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf * statPtr); /* 601 */
    int (*tcl_SetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * paramList); /* 602 */
    int (*tcl_GetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** paramListPtr); /* 603 */
    int (*tcl_ParseArgsObjv) (Tcl_Interp * interp, const Tcl_ArgvInfo * argTable, int * objcPtr, Tcl_Obj *const * objv, Tcl_Obj *** remObjv); /* 604 */


} TclStubs;

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
extern const TclStubs *tclStubsPtr;
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
................................................................................
#define Tcl_GetEnsembleParameterList \
	(tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */
#endif
#ifndef Tcl_ParseArgsObjv
#define Tcl_ParseArgsObjv \
	(tclStubsPtr->tcl_ParseArgsObjv) /* 604 */
#endif









#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLDECLS */







|







 







>
>
>
>
>
>
>
>
>
>







 







>
>







 







>
>
>
>
>
>
>
>










4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
....
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
....
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
 *	Declarations of functions in the platform independent public Tcl API.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclDecls.h,v 1.157 2008/12/02 19:40:41 dgp Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
#ifndef Tcl_ParseArgsObjv_TCL_DECLARED
#define Tcl_ParseArgsObjv_TCL_DECLARED
/* 604 */
EXTERN int		Tcl_ParseArgsObjv (Tcl_Interp * interp,
				const Tcl_ArgvInfo * argTable, int * objcPtr,
				Tcl_Obj *const * objv, Tcl_Obj *** remObjv);
#endif
#ifndef Tcl_GetErrorLine_TCL_DECLARED
#define Tcl_GetErrorLine_TCL_DECLARED
/* 605 */
EXTERN int		Tcl_GetErrorLine (Tcl_Interp * interp);
#endif
#ifndef Tcl_SetErrorLine_TCL_DECLARED
#define Tcl_SetErrorLine_TCL_DECLARED
/* 606 */
EXTERN void		Tcl_SetErrorLine (Tcl_Interp * interp, int value);
#endif

typedef struct TclStubHooks {
    const struct TclPlatStubs *tclPlatStubs;
    const struct TclIntStubs *tclIntStubs;
    const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;

................................................................................
    Tcl_WideInt (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf * statPtr); /* 598 */
    Tcl_WideUInt (*tcl_GetSizeFromStat) (const Tcl_StatBuf * statPtr); /* 599 */
    Tcl_WideUInt (*tcl_GetBlocksFromStat) (const Tcl_StatBuf * statPtr); /* 600 */
    unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf * statPtr); /* 601 */
    int (*tcl_SetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj * paramList); /* 602 */
    int (*tcl_GetEnsembleParameterList) (Tcl_Interp * interp, Tcl_Command token, Tcl_Obj ** paramListPtr); /* 603 */
    int (*tcl_ParseArgsObjv) (Tcl_Interp * interp, const Tcl_ArgvInfo * argTable, int * objcPtr, Tcl_Obj *const * objv, Tcl_Obj *** remObjv); /* 604 */
    int (*tcl_GetErrorLine) (Tcl_Interp * interp); /* 605 */
    void (*tcl_SetErrorLine) (Tcl_Interp * interp, int value); /* 606 */
} TclStubs;

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
extern const TclStubs *tclStubsPtr;
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
................................................................................
#define Tcl_GetEnsembleParameterList \
	(tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */
#endif
#ifndef Tcl_ParseArgsObjv
#define Tcl_ParseArgsObjv \
	(tclStubsPtr->tcl_ParseArgsObjv) /* 604 */
#endif
#ifndef Tcl_GetErrorLine
#define Tcl_GetErrorLine \
	(tclStubsPtr->tcl_GetErrorLine) /* 605 */
#endif
#ifndef Tcl_SetErrorLine
#define Tcl_SetErrorLine \
	(tclStubsPtr->tcl_SetErrorLine) /* 606 */
#endif

#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */

/* !END!: Do not edit above this line. */

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

#endif /* _TCLDECLS */

Changes to generic/tclDictObj.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
....
2504
2505
2506
2507
2508
2509
2510
2511

2512
2513
2514
2515
2516
2517
2518
....
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
 *	and its accessor command.
 *
 * Copyright (c) 2002 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: tclDictObj.c,v 1.70 2008/11/17 22:15:34 nijtmans Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Forward declaration.
................................................................................
	result = TCL_OK;
    } else if (result != TCL_OK) {
	if (result == TCL_BREAK) {
	    Tcl_ResetResult(interp);
	    result = TCL_OK;
	} else if (result == TCL_ERROR) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (\"dict for\" body line %d)", interp->errorLine));

	}
	goto done;
    }

    /*
     * Get the next mapping from the dictionary.
     */
................................................................................
		Tcl_DictObjDone(&search);
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_ERROR:
		Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			"\n    (\"dict filter\" script line %d)",
			interp->errorLine));
	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);







|







 







|
>







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
....
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
....
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
 *	and its accessor command.
 *
 * Copyright (c) 2002 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: tclDictObj.c,v 1.71 2008/12/02 19:40:41 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Forward declaration.
................................................................................
	result = TCL_OK;
    } else if (result != TCL_OK) {
	if (result == TCL_BREAK) {
	    Tcl_ResetResult(interp);
	    result = TCL_OK;
	} else if (result == TCL_ERROR) {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (\"dict for\" body line %d)",
		    Tcl_GetErrorLine(interp)));
	}
	goto done;
    }

    /*
     * Get the next mapping from the dictionary.
     */
................................................................................
		Tcl_DictObjDone(&search);
	    case TCL_CONTINUE:
		result = TCL_OK;
		break;
	    case TCL_ERROR:
		Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
			"\n    (\"dict filter\" script line %d)",
			Tcl_GetErrorLine(interp)));
	    default:
		goto abnormalResult;
	    }

	    TclDecrRefCount(keyObj);
	    TclDecrRefCount(valueObj);

Changes to generic/tclIOUtil.c.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
....
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.159 2008/11/13 22:34:33 nijtmans Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
................................................................................
	const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	int limit = 150;
	int overflow = (length > limit);

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (file \"%.*s%s\" line %d)",
		(overflow ? limit : length), pathString,
		(overflow ? "..." : ""), interp->errorLine));
    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}
 






|







 







|







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
....
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 2001-2004 Vincent Darley.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIOUtil.c,v 1.160 2008/12/02 19:40:41 dgp Exp $
 */

#include "tclInt.h"
#ifdef __WIN32__
#   include "tclWinInt.h"
#endif
#include "tclFileSystem.h"
................................................................................
	const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
	int limit = 150;
	int overflow = (length > limit);

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (file \"%.*s%s\" line %d)",
		(overflow ? limit : length), pathString,
		(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
    }

  end:
    Tcl_DecrRefCount(objPtr);
    return result;
}
 

Changes to generic/tclNamesp.c.

19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
....
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
 *   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.182 2008/11/11 21:54:06 nijtmans Exp $
 */

#include "tclInt.h"

/*
 * Thread-local storage used to avoid having a global lock on data that is not
 * limited to a single interpreter.
................................................................................
	int overflow = (length > limit);
	char *cmd = data[1];

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (in namespace %s \"%.*s%s\" script line %d)",
		cmd,
		(overflow ? limit : length), namespacePtr->fullName,
		(overflow ? "..." : ""), interp->errorLine));
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);






|







 







|







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
....
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
 *   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.183 2008/12/02 19:40:41 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.
................................................................................
	int overflow = (length > limit);
	char *cmd = data[1];

	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (in namespace %s \"%.*s%s\" script line %d)",
		cmd,
		(overflow ? limit : length), namespacePtr->fullName,
		(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
    }

    /*
     * Restore the previous "current" namespace.
     */

    TclPopStackFrame(interp);

Changes to generic/tclOOBasic.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
....
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
 *	methods from the object-system core.
 *
 * Copyright (c) 2005-2008 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: tclOOBasic.c,v 1.15 2008/11/01 00:04:26 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
	Object *oPtr = data[0];

	if (oPtr) {
	    Tcl_Obj *objnameObj = TclOOObjectName(interp, oPtr);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in \"%s eval\" script line %d)",
		    TclGetString(objnameObj), interp->errorLine));
	} else {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in \"my eval\" script line %d)",
		    interp->errorLine));
	}
    }

    /*
     * Restore the previous "current" namespace.
     */

................................................................................
    CallFrame *savedFramePtr = data[0];
    Tcl_Obj *resultObj[2];
    int rewind = iPtr->execEnvPtr->rewind;

    iPtr->varFramePtr = savedFramePtr;
    if (rewind || Tcl_LimitExceeded(interp)) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"UpCatch\" body line %d)", interp->errorLine));
	return TCL_ERROR;
    }
    resultObj[0] = Tcl_GetObjResult(interp);
    resultObj[1] = Tcl_GetReturnOptions(interp, result);
    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
    return TCL_OK;
}






|







 







|



|







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
....
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
 *	methods from the object-system core.
 *
 * Copyright (c) 2005-2008 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: tclOOBasic.c,v 1.16 2008/12/02 19:40:41 dgp Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
	Object *oPtr = data[0];

	if (oPtr) {
	    Tcl_Obj *objnameObj = TclOOObjectName(interp, oPtr);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in \"%s eval\" script line %d)",
		    TclGetString(objnameObj), Tcl_GetErrorLine(interp)));
	} else {
	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in \"my eval\" script line %d)",
		    Tcl_GetErrorLine(interp)));
	}
    }

    /*
     * Restore the previous "current" namespace.
     */

................................................................................
    CallFrame *savedFramePtr = data[0];
    Tcl_Obj *resultObj[2];
    int rewind = iPtr->execEnvPtr->rewind;

    iPtr->varFramePtr = savedFramePtr;
    if (rewind || Tcl_LimitExceeded(interp)) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp)));
	return TCL_ERROR;
    }
    resultObj[0] = Tcl_GetObjResult(interp);
    resultObj[1] = Tcl_GetReturnOptions(interp, result);
    Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj));
    return TCL_OK;
}

Changes to generic/tclOODefineCmds.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
...
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
...
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
 *	part of the object-system core (NB: not Tcl_Obj, but ::oo).
 *
 * Copyright (c) 2006-2008 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: tclOODefineCmds.c,v 1.7 2008/10/31 22:08:32 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), interp->errorLine));
	}
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

................................................................................
	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), interp->errorLine));
	}
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

................................................................................
		    TclOOObjectName(interp, oPtr), &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), interp->errorLine));
	}
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;







|







 







|







 







|







 







|







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
...
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
...
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
 *	part of the object-system core (NB: not Tcl_Obj, but ::oo).
 *
 * Copyright (c) 2006-2008 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: tclOODefineCmds.c,v 1.8 2008/12/02 19:40:41 dgp Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
	}
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

................................................................................
	    const char *objName = Tcl_GetStringFromObj(objv[1], &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
	}
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

................................................................................
		    TclOOObjectName(interp, oPtr), &length);
	    int limit = 60;
	    int overflow = (length > limit);

	    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		    "\n    (in definition script for object \"%.*s%s\" line %d)",
		    (overflow ? limit : length), objName,
		    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
	}
    } else {
	Tcl_Obj *objPtr, *obj2Ptr, **objs;
	Interp *iPtr = (Interp *) interp;
	Tcl_Command cmd;
	int dummy;

Changes to generic/tclOOMethod.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
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
1194
1195
1196
1197
....
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
....
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
 *	This file contains code to create and manage methods.
 *
 * Copyright (c) 2005-2008 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: tclOOMethod.c,v 1.20 2008/09/24 09:51:47 dkf Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
	    &objectNameLen);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
	    kindName, ELLIPSIFY(objectName, objectNameLen),
	    ELLIPSIFY(methodName, nameLen), interp->errorLine));
}

static void
ConstructorErrorHandler(
    Tcl_Interp *interp,
    Tcl_Obj *methodNameObj)
{
    CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    int objectNameLen;

    if (interp->errorLine == (int) 0xDEADBEEF) {
	/*
	 * Horrible hack to deal with certain constructors that must not add
	 * information to the error trace.
	 */

	return;
    }
................................................................................
	kindName = "class";
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
	    &objectNameLen);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (%s \"%.*s%s\" constructor line %d)", kindName,
	    ELLIPSIFY(objectName, objectNameLen), interp->errorLine));
}

static void
DestructorErrorHandler(
    Tcl_Interp *interp,
    Tcl_Obj *methodNameObj)
{
................................................................................
	kindName = "class";
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
	    &objectNameLen);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (%s \"%.*s%s\" destructor line %d)", kindName,
	    ELLIPSIFY(objectName, objectNameLen), interp->errorLine));
}
 
/*
 * ----------------------------------------------------------------------
 *
 * DeleteProcedureMethod, CloneProcedureMethod --
 *






|







 







|













|







 







|







 







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
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
1194
1195
1196
1197
....
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
....
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
 *	This file contains code to create and manage methods.
 *
 * Copyright (c) 2005-2008 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: tclOOMethod.c,v 1.21 2008/12/02 19:40:41 dgp Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
	    &objectNameLen);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
	    kindName, ELLIPSIFY(objectName, objectNameLen),
	    ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
}

static void
ConstructorErrorHandler(
    Tcl_Interp *interp,
    Tcl_Obj *methodNameObj)
{
    CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData;
    Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
    Object *declarerPtr;
    const char *objectName, *kindName;
    int objectNameLen;

    if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) {
	/*
	 * Horrible hack to deal with certain constructors that must not add
	 * information to the error trace.
	 */

	return;
    }
................................................................................
	kindName = "class";
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
	    &objectNameLen);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (%s \"%.*s%s\" constructor line %d)", kindName,
	    ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
}

static void
DestructorErrorHandler(
    Tcl_Interp *interp,
    Tcl_Obj *methodNameObj)
{
................................................................................
	kindName = "class";
    }

    objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
	    &objectNameLen);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (%s \"%.*s%s\" destructor line %d)", kindName,
	    ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
}
 
/*
 * ----------------------------------------------------------------------
 *
 * DeleteProcedureMethod, CloneProcedureMethod --
 *

Changes to generic/tclProc.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
....
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
....
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
 * 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.167 2008/10/28 23:29:54 nijtmans Exp $
 */

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

/*
................................................................................
    Tcl_Interp *interp,
    int result)
{
    CallFrame *savedVarFramePtr = data[0];

    if (result == TCL_ERROR) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"uplevel\" body line %d)", interp->errorLine));
    }

    /*
     * Restore the variable frame, and return.
     */

    ((Interp *)interp)->varFramePtr = savedVarFramePtr;
................................................................................
    int overflow, limit = 60, nameLen;
    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);

    overflow = (nameLen > limit);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (procedure \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), interp->errorLine));
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --
 *
................................................................................
    int overflow, limit = 60, nameLen;
    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);

    overflow = (nameLen > limit);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (lambda term \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), interp->errorLine));
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DisassembleObjCmd --
 *






|







 







|







 







|







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
....
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
....
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
 * 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.168 2008/12/02 19:40:41 dgp Exp $
 */

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

/*
................................................................................
    Tcl_Interp *interp,
    int result)
{
    CallFrame *savedVarFramePtr = data[0];

    if (result == TCL_ERROR) {
	Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
		"\n    (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)));
    }

    /*
     * Restore the variable frame, and return.
     */

    ((Interp *)interp)->varFramePtr = savedVarFramePtr;
................................................................................
    int overflow, limit = 60, nameLen;
    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);

    overflow = (nameLen > limit);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (procedure \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclProcDeleteProc --
 *
................................................................................
    int overflow, limit = 60, nameLen;
    const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);

    overflow = (nameLen > limit);
    Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
	    "\n    (lambda term \"%.*s%s\" line %d)",
	    (overflow ? limit : nameLen), procName,
	    (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DisassembleObjCmd --
 *

Changes to generic/tclResult.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
1076
1077
1078
1079
1080
1081
1082







































1083
1084
1085
1086
1087
1088
1089
 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by 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: tclResult.c,v 1.51 2008/10/26 18:34:04 dkf Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */
................................................................................

    if (iPtr->errorCode) {
	Tcl_DecrRefCount(iPtr->errorCode);
    }
    iPtr->errorCode = errorObjPtr;
    Tcl_IncrRefCount(iPtr->errorCode);
}







































 
/*
 *----------------------------------------------------------------------
 *
 * GetKeys --
 *
 *	Returns a Tcl_Obj * array of the standard keys used in the return






|







 







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







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
 *	This file contains code to manage the interpreter result.
 *
 * Copyright (c) 1997 by 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: tclResult.c,v 1.52 2008/12/02 19:40:41 dgp Exp $
 */

#include "tclInt.h"

/*
 * Indices of the standard return options dictionary keys.
 */
................................................................................

    if (iPtr->errorCode) {
	Tcl_DecrRefCount(iPtr->errorCode);
    }
    iPtr->errorCode = errorObjPtr;
    Tcl_IncrRefCount(iPtr->errorCode);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetErrorLine --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetErrorLine(
    Tcl_Interp *interp)
{
    return ((Interp *) interp)->errorLine;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorLine --
 *
 * Results:
 *
 * Side effects:
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetErrorLine(
    Tcl_Interp *interp,
    int value)
{
    ((Interp *) interp)->errorLine = value;
}
 
/*
 *----------------------------------------------------------------------
 *
 * GetKeys --
 *
 *	Returns a Tcl_Obj * array of the standard keys used in the return

Changes to generic/tclStubInit.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
1126
1127
1128
1129
1130
1131
1132


1133
1134
1135
1136
1137
1138
1139
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.167 2008/10/22 20:23:59 nijtmans Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Remove macros that will interfere with the definitions below.
................................................................................
    Tcl_GetChangeTimeFromStat, /* 598 */
    Tcl_GetSizeFromStat, /* 599 */
    Tcl_GetBlocksFromStat, /* 600 */
    Tcl_GetBlockSizeFromStat, /* 601 */
    Tcl_SetEnsembleParameterList, /* 602 */
    Tcl_GetEnsembleParameterList, /* 603 */
    Tcl_ParseArgsObjv, /* 604 */


};

/* !END!: Do not edit above this line. */

/*
 * Module-scope pointers to the main static stubs tables, used for package
 * initialization via Tcl_PkgProvideEx().






|







 







>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
....
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
 *	This file contains the initializers for the Tcl stub vectors.
 *
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclStubInit.c,v 1.168 2008/12/02 19:40:41 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

/*
 * Remove macros that will interfere with the definitions below.
................................................................................
    Tcl_GetChangeTimeFromStat, /* 598 */
    Tcl_GetSizeFromStat, /* 599 */
    Tcl_GetBlocksFromStat, /* 600 */
    Tcl_GetBlockSizeFromStat, /* 601 */
    Tcl_SetEnsembleParameterList, /* 602 */
    Tcl_GetEnsembleParameterList, /* 603 */
    Tcl_ParseArgsObjv, /* 604 */
    Tcl_GetErrorLine, /* 605 */
    Tcl_SetErrorLine, /* 606 */
};

/* !END!: Do not edit above this line. */

/*
 * Module-scope pointers to the main static stubs tables, used for package
 * initialization via Tcl_PkgProvideEx().