Tcl Source Code

Check-in [4f99dac9fd]
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:
* doc/Object.3 CONSTified 3 functions using * doc/ObjectType.3 Tcl_ObjType which all are supposed * generic/tcl.decls to be a constant, but this was not * generic/tcl.h reflected in the API: * generic/tclDecls.h Tcl_ConvertToType * generic/tclObj.c Tcl_GetObjType * generic/tclCompCmds.c Tcl_RegisterObjType * generic/tclOOMethod.c Introduced a CONST86_RETURN, so extensions which * generic/tclTestobj.c use Tcl_ObjType directly can be modified to compile against both Tcl 8.5 and Tcl 8.6 tclDecls.h is re-generated with "make genstubs" This change complies with TIP #24 ***POTENTIAL INCOMPATIBILITY***
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | potential incompatibility
Files: files | file ages | folders
SHA1: 4f99dac9fd9e8c3cad5772fdaff95f8bc8fd660a
User & Date: nijtmans 2008-07-27 22:18:21
Context
2008-07-27
22:28
Remove unnecessary hack. check-in: 697475bbe2 user: dkf tags: trunk
22:18
* doc/Object.3 CONSTified 3 functions using * doc/ObjectType.3 Tcl_ObjType which all...
check-in: 4f99dac9fd user: nijtmans tags: trunk, potential incompatibility
2008-07-25
23:06
* test/info.test: More work on singleTestInterp usability. This fixes bug [1605269]. check-in: b3b434585c user: andreas_kupries tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.

















1
2
3
4
5
6
7















2008-07-25  Andreas Kupries  <[email protected]>

	* test/info.test: More work on singleTestInterp usability. This
	fixes bug [1605269].

	* tests/info.test: Tests 38.* added, exactly testing the tracking
	of location for uplevel scripts. Resolved merge conflict on
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
2007-07-27  Jan Nijtmans  <[email protected]>

       * doc/Object.3          CONSTified 3 functions using
       * doc/ObjectType.3      Tcl_ObjType which all are supposed
       * generic/tcl.decls     to be a constant, but this was not
       * generic/tcl.h         reflected in the API:
       * generic/tclDecls.h      Tcl_ConvertToType
       * generic/tclObj.c        Tcl_GetObjType
       * generic/tclCompCmds.c   Tcl_RegisterObjType
       * generic/tclOOMethod.c Introduced a CONST86_RETURN, so extensions which
       * generic/tclTestobj.c  use Tcl_ObjType directly can be modified to compile
                               against both Tcl 8.5 and Tcl 8.6
       tclDecls.h is re-generated with "make genstubs"
       This change complies with TIP #24
       ***POTENTIAL INCOMPATIBILITY***

2008-07-25  Andreas Kupries  <[email protected]>

	* test/info.test: More work on singleTestInterp usability. This
	fixes bug [1605269].

	* tests/info.test: Tests 38.* added, exactly testing the tracking
	of location for uplevel scripts. Resolved merge conflict on

Changes to doc/Object.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
...
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
'\"
'\" Copyright (c) 1996-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: Object.3,v 1.20 2008/06/29 22:28:24 dkf Exp $
'\" 
.so man.macros
.TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects
.SH SYNOPSIS
................................................................................
Each Tcl object is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.CS
typedef struct Tcl_Obj {
    int \fIrefCount\fR;
    char *\fIbytes\fR;
    int \fIlength\fR;
    Tcl_ObjType *\fItypePtr\fR;
    union {
        long \fIlongValue\fR;
        double \fIdoubleValue\fR;
        void *\fIotherValuePtr\fR;
        Tcl_WideInt \fIwideValue\fR;
        struct {
            void *\fIptr1\fR;





|







 







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
...
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
'\"
'\" Copyright (c) 1996-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: Object.3,v 1.21 2008/07/27 22:18:21 nijtmans Exp $
'\" 
.so man.macros
.TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects
.SH SYNOPSIS
................................................................................
Each Tcl object is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.CS
typedef struct Tcl_Obj {
    int \fIrefCount\fR;
    char *\fIbytes\fR;
    int \fIlength\fR;
    const Tcl_ObjType *\fItypePtr\fR;
    union {
        long \fIlongValue\fR;
        double \fIdoubleValue\fR;
        void *\fIotherValuePtr\fR;
        Tcl_WideInt \fIwideValue\fR;
        struct {
            void *\fIptr1\fR;

Changes to doc/ObjectType.3.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
'\"
'\" Copyright (c) 1996-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: ObjectType.3,v 1.19 2008/06/30 15:58:06 dgp Exp $
'\" 
.so man.macros
.TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType  \- manipulate Tcl object types
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_RegisterObjType\fR(\fItypePtr\fR)
.sp
Tcl_ObjType *
\fBTcl_GetObjType\fR(\fItypeName\fR)
.sp
int
\fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR)
.SH ARGUMENTS
.AS "const char" *typeName
.AP Tcl_ObjType *typePtr in
Points to the structure containing information about the Tcl object type.
This storage must live forever,
typically by being statically allocated.
.AP "const char" *typeName in
The name of a Tcl object type that \fBTcl_GetObjType\fR should look up.
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
................................................................................
structire to \fBTcl_RegisterObjType\fR if they wish to permit
other extensions to look up their Tcl_ObjType by name with
the \fBTcl_GetObjType\fR routine.
The \fBTcl_ObjType\fR structure is defined as follows:
.PP
.CS
typedef struct Tcl_ObjType {
    char *\fIname\fR;
    Tcl_FreeInternalRepProc *\fIfreeIntRepProc\fR;
    Tcl_DupInternalRepProc *\fIdupIntRepProc\fR;
    Tcl_UpdateStringProc *\fIupdateStringProc\fR;
    Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR;
} \fBTcl_ObjType\fR;
.CE
.SS "THE NAME FIELD"





|












|









|







 







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
...
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
'\"
'\" Copyright (c) 1996-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: ObjectType.3,v 1.20 2008/07/27 22:18:21 nijtmans Exp $
'\" 
.so man.macros
.TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType  \- manipulate Tcl object types
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_RegisterObjType\fR(\fItypePtr\fR)
.sp
const Tcl_ObjType *
\fBTcl_GetObjType\fR(\fItypeName\fR)
.sp
int
\fBTcl_AppendAllObjTypes\fR(\fIinterp, objPtr\fR)
.sp
int
\fBTcl_ConvertToType\fR(\fIinterp, objPtr, typePtr\fR)
.SH ARGUMENTS
.AS "const char" *typeName
.AP "const Tcl_ObjType" *typePtr in
Points to the structure containing information about the Tcl object type.
This storage must live forever,
typically by being statically allocated.
.AP "const char" *typeName in
The name of a Tcl object type that \fBTcl_GetObjType\fR should look up.
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
................................................................................
structire to \fBTcl_RegisterObjType\fR if they wish to permit
other extensions to look up their Tcl_ObjType by name with
the \fBTcl_GetObjType\fR routine.
The \fBTcl_ObjType\fR structure is defined as follows:
.PP
.CS
typedef struct Tcl_ObjType {
    const char *\fIname\fR;
    Tcl_FreeInternalRepProc *\fIfreeIntRepProc\fR;
    Tcl_DupInternalRepProc *\fIdupIntRepProc\fR;
    Tcl_UpdateStringProc *\fIupdateStringProc\fR;
    Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR;
} \fBTcl_ObjType\fR;
.CE
.SS "THE NAME FIELD"

Changes to generic/tcl.decls.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
...
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
...
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
# 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.139 2008/07/24 22:57:57 nijtmans Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private
................................................................................
    void Tcl_AppendToObj(Tcl_Obj* objPtr, CONST char* bytes, int length)
}
declare 17 generic {
    Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[])
}
declare 18 generic {
    int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    Tcl_ObjType *typePtr)
}
declare 19 generic {
    void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
}
declare 20 generic {
    void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
}
................................................................................
declare 38 generic {
    int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 generic {
    int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
declare 40 generic {
    Tcl_ObjType * Tcl_GetObjType(CONST char *typeName)
}
declare 41 generic {
    char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 42 generic {
    void Tcl_InvalidateStringRep(Tcl_Obj *objPtr)
}
................................................................................
declare 209 generic {
    int Tcl_RecordAndEvalObj(Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags)
}
declare 210 generic {
    void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 211 generic {
    void Tcl_RegisterObjType(Tcl_ObjType *typePtr)
}
declare 212 generic {
    Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *pattern)
}
declare 213 generic {
    int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
	    CONST char *text, CONST char *start)






|







 







|







 







|







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
...
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
...
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
# 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.140 2008/07/27 22:18:21 nijtmans Exp $

library tcl

# Define the tcl interface with several sub interfaces:
#     tclPlat	 - platform specific public
#     tclInt	 - generic private
#     tclPlatInt - platform specific private
................................................................................
    void Tcl_AppendToObj(Tcl_Obj* objPtr, CONST char* bytes, int length)
}
declare 17 generic {
    Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[])
}
declare 18 generic {
    int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
	    CONST86 Tcl_ObjType *typePtr)
}
declare 19 generic {
    void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
}
declare 20 generic {
    void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
}
................................................................................
declare 38 generic {
    int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 generic {
    int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
declare 40 generic {
    CONST86_RETURN Tcl_ObjType * Tcl_GetObjType(CONST char *typeName)
}
declare 41 generic {
    char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 42 generic {
    void Tcl_InvalidateStringRep(Tcl_Obj *objPtr)
}
................................................................................
declare 209 generic {
    int Tcl_RecordAndEvalObj(Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags)
}
declare 210 generic {
    void Tcl_RegisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 211 generic {
    void Tcl_RegisterObjType(CONST86 Tcl_ObjType *typePtr)
}
declare 212 generic {
    Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *pattern)
}
declare 213 generic {
    int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
	    CONST char *text, CONST char *start)

Changes to generic/tcl.h.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
258
259
260
261
262
263
264

265
266
267
268
269
270
271
...
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
...
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
 * 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.262 2008/07/24 21:54:38 nijtmans Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
#   else
#      define CONST84 CONST
#      define CONST84_RETURN CONST
#   endif
#endif

#define CONST86 CONST84


/*
 * Make sure EXTERN isn't defined elsewhere
 */

#ifdef EXTERN
#   undef EXTERN
................................................................................
/*
 * The following structure represents a type of object, which is a particular
 * internal representation for an object plus a set of functions that provide
 * standard operations on objects of that type.
 */

typedef struct Tcl_ObjType {
    char *name;			/* Name of the type, e.g. "int". */
    Tcl_FreeInternalRepProc *freeIntRepProc;
				/* Called to free any storage for the type's
				 * internal rep. NULL if the internal rep does
				 * not need freeing. */
    Tcl_DupInternalRepProc *dupIntRepProc;
				/* Called to create a new object as a copy of
				 * an existing object. */
................................................................................
				 * the string rep is invalid and must be
				 * regenerated from the internal rep.  Clients
				 * should use Tcl_GetStringFromObj or
				 * Tcl_GetString to get a pointer to the byte
				 * array as a readonly value. */
    int length;			/* The number of bytes at *bytes, not
				 * including the terminating null. */
    Tcl_ObjType *typePtr;	/* Denotes the object's type. Always
				 * corresponds to the type of the object's
				 * internal rep. NULL indicates the object has
				 * no internal rep (has no type). */
    union {			/* The internal representation: */
	long longValue;		/*   - an long integer value */
	double doubleValue;	/*   - a double-precision floating value */
	VOID *otherValuePtr;	/*   - another, type-specific value */






|







 







>







 







|







 







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
...
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
...
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
 * 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.263 2008/07/27 22:18:23 nijtmans Exp $
 */

#ifndef _TCL
#define _TCL

/*
 * For C++ compilers, use extern "C"
................................................................................
#   else
#      define CONST84 CONST
#      define CONST84_RETURN CONST
#   endif
#endif

#define CONST86 CONST84
#define CONST86_RETURN CONST84_RETURN

/*
 * Make sure EXTERN isn't defined elsewhere
 */

#ifdef EXTERN
#   undef EXTERN
................................................................................
/*
 * The following structure represents a type of object, which is a particular
 * internal representation for an object plus a set of functions that provide
 * standard operations on objects of that type.
 */

typedef struct Tcl_ObjType {
    CONST86 char *name;			/* Name of the type, e.g. "int". */
    Tcl_FreeInternalRepProc *freeIntRepProc;
				/* Called to free any storage for the type's
				 * internal rep. NULL if the internal rep does
				 * not need freeing. */
    Tcl_DupInternalRepProc *dupIntRepProc;
				/* Called to create a new object as a copy of
				 * an existing object. */
................................................................................
				 * the string rep is invalid and must be
				 * regenerated from the internal rep.  Clients
				 * should use Tcl_GetStringFromObj or
				 * Tcl_GetString to get a pointer to the byte
				 * array as a readonly value. */
    int length;			/* The number of bytes at *bytes, not
				 * including the terminating null. */
    CONST86 Tcl_ObjType *typePtr;	/* Denotes the object's type. Always
				 * corresponds to the type of the object's
				 * internal rep. NULL indicates the object has
				 * no internal rep (has no type). */
    union {			/* The internal representation: */
	long longValue;		/*   - an long integer value */
	double doubleValue;	/*   - a double-precision floating value */
	VOID *otherValuePtr;	/*   - another, type-specific value */

Changes to generic/tclCompCmds.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
....
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2004-2006 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompCmds.c,v 1.145 2008/06/08 03:21:32 msofer Exp $
 */

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

/*
 * Macro that encapsulates an efficiency trick that avoids a function call for
................................................................................
	    return TCL_ERROR;
	}
	resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
		resultNameTokenPtr[1].size, /*create*/ 1, envPtr);
	if (resultIndex < 0) {
	    return TCL_ERROR;
	}
	
	/* DKF */
	if (parsePtr->numWords == 4) {
	    optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
	    if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		return TCL_ERROR;
	    }
	    name = optsNameTokenPtr[1].start;
................................................................................
    /*
     * Push the frame index if it is known at compile time
     */

    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
	CallFrame *framePtr;
	Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;

	/*
	 * Attempt to convert to a level reference. Note that TclObjGetFrame
	 * only changes the obj type when a conversion was successful.
	 */

	TclObjGetFrame(interp, objPtr, &framePtr);






|







 







|







 







|







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
...
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
....
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2002 ActiveState Corporation.
 * Copyright (c) 2004-2006 by Donal K. Fellows.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCompCmds.c,v 1.146 2008/07/27 22:18:22 nijtmans Exp $
 */

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

/*
 * Macro that encapsulates an efficiency trick that avoids a function call for
................................................................................
	    return TCL_ERROR;
	}
	resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
		resultNameTokenPtr[1].size, /*create*/ 1, envPtr);
	if (resultIndex < 0) {
	    return TCL_ERROR;
	}

	/* DKF */
	if (parsePtr->numWords == 4) {
	    optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
	    if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
		return TCL_ERROR;
	    }
	    name = optsNameTokenPtr[1].start;
................................................................................
    /*
     * Push the frame index if it is known at compile time
     */

    tokenPtr = TokenAfter(parsePtr->tokenPtr);
    if(TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
	CallFrame *framePtr;
	const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;

	/*
	 * Attempt to convert to a level reference. Note that TclObjGetFrame
	 * only changes the obj type when a conversion was successful.
	 */

	TclObjGetFrame(interp, objPtr, &framePtr);

Changes to generic/tclDecls.h.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
156
157
158
159
160
161
162

163
164
165
166
167
168
169
170
...
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
....
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
....
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
....
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
....
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
 *	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.141 2008/07/24 22:57:57 nijtmans Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
/* 17 */
EXTERN Tcl_Obj *	Tcl_ConcatObj (int objc, Tcl_Obj *CONST objv[]);
#endif
#ifndef Tcl_ConvertToType_TCL_DECLARED
#define Tcl_ConvertToType_TCL_DECLARED
/* 18 */
EXTERN int		Tcl_ConvertToType (Tcl_Interp * interp, 

				Tcl_Obj * objPtr, Tcl_ObjType * typePtr);
#endif
#ifndef Tcl_DbDecrRefCount_TCL_DECLARED
#define Tcl_DbDecrRefCount_TCL_DECLARED
/* 19 */
EXTERN void		Tcl_DbDecrRefCount (Tcl_Obj * objPtr, 
				CONST char * file, int line);
#endif
................................................................................
/* 39 */
EXTERN int		Tcl_GetLongFromObj (Tcl_Interp * interp, 
				Tcl_Obj * objPtr, long * longPtr);
#endif
#ifndef Tcl_GetObjType_TCL_DECLARED
#define Tcl_GetObjType_TCL_DECLARED
/* 40 */
EXTERN Tcl_ObjType *	Tcl_GetObjType (CONST char * typeName);
#endif
#ifndef Tcl_GetStringFromObj_TCL_DECLARED
#define Tcl_GetStringFromObj_TCL_DECLARED
/* 41 */
EXTERN char *		Tcl_GetStringFromObj (Tcl_Obj * objPtr, 
				int * lengthPtr);
#endif
................................................................................
/* 210 */
EXTERN void		Tcl_RegisterChannel (Tcl_Interp * interp, 
				Tcl_Channel chan);
#endif
#ifndef Tcl_RegisterObjType_TCL_DECLARED
#define Tcl_RegisterObjType_TCL_DECLARED
/* 211 */
EXTERN void		Tcl_RegisterObjType (Tcl_ObjType * typePtr);
#endif
#ifndef Tcl_RegExpCompile_TCL_DECLARED
#define Tcl_RegExpCompile_TCL_DECLARED
/* 212 */
EXTERN Tcl_RegExp	Tcl_RegExpCompile (Tcl_Interp * interp, 
				CONST char * pattern);
#endif
................................................................................
    void (*tcl_SetTimer) (CONST86 Tcl_Time * timePtr); /* 11 */
    void (*tcl_Sleep) (int ms); /* 12 */
    int (*tcl_WaitForEvent) (CONST86 Tcl_Time * timePtr); /* 13 */
    int (*tcl_AppendAllObjTypes) (Tcl_Interp * interp, Tcl_Obj * objPtr); /* 14 */
    void (*tcl_AppendStringsToObj) (Tcl_Obj * objPtr, ...); /* 15 */
    void (*tcl_AppendToObj) (Tcl_Obj* objPtr, CONST char* bytes, int length); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *CONST objv[]); /* 17 */
    int (*tcl_ConvertToType) (Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr); /* 18 */
    void (*tcl_DbDecrRefCount) (Tcl_Obj * objPtr, CONST char * file, int line); /* 19 */
    void (*tcl_DbIncrRefCount) (Tcl_Obj * objPtr, CONST char * file, int line); /* 20 */
    int (*tcl_DbIsShared) (Tcl_Obj * objPtr, CONST char * file, int line); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, CONST char * file, int line); /* 22 */
    Tcl_Obj * (*tcl_DbNewByteArrayObj) (CONST unsigned char * bytes, int length, CONST char * file, int line); /* 23 */
    Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, CONST char * file, int line); /* 24 */
    Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *CONST * objv, CONST char * file, int line); /* 25 */
................................................................................
    unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj * objPtr, int * lengthPtr); /* 33 */
    int (*tcl_GetDouble) (Tcl_Interp * interp, CONST char * src, double * doublePtr); /* 34 */
    int (*tcl_GetDoubleFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr); /* 35 */
    int (*tcl_GetIndexFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr); /* 36 */
    int (*tcl_GetInt) (Tcl_Interp * interp, CONST char * src, int * intPtr); /* 37 */
    int (*tcl_GetIntFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr); /* 38 */
    int (*tcl_GetLongFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr); /* 39 */
    Tcl_ObjType * (*tcl_GetObjType) (CONST char * typeName); /* 40 */
    char * (*tcl_GetStringFromObj) (Tcl_Obj * objPtr, int * lengthPtr); /* 41 */
    void (*tcl_InvalidateStringRep) (Tcl_Obj * objPtr); /* 42 */
    int (*tcl_ListObjAppendList) (Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr); /* 43 */
    int (*tcl_ListObjAppendElement) (Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr); /* 44 */
    int (*tcl_ListObjGetElements) (Tcl_Interp * interp, Tcl_Obj * listPtr, int * objcPtr, Tcl_Obj *** objvPtr); /* 45 */
    int (*tcl_ListObjIndex) (Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj ** objPtrPtr); /* 46 */
    int (*tcl_ListObjLength) (Tcl_Interp * interp, Tcl_Obj * listPtr, int * lengthPtr); /* 47 */
................................................................................
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    void (*tcl_ReapDetachedProcs) (void); /* 207 */
#endif /* MACOSX */
    int (*tcl_RecordAndEval) (Tcl_Interp * interp, CONST char * cmd, int flags); /* 208 */
    int (*tcl_RecordAndEvalObj) (Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags); /* 209 */
    void (*tcl_RegisterChannel) (Tcl_Interp * interp, Tcl_Channel chan); /* 210 */
    void (*tcl_RegisterObjType) (Tcl_ObjType * typePtr); /* 211 */
    Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp * interp, CONST char * pattern); /* 212 */
    int (*tcl_RegExpExec) (Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * text, CONST char * start); /* 213 */
    int (*tcl_RegExpMatch) (Tcl_Interp * interp, CONST char * text, CONST char * pattern); /* 214 */
    void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr); /* 215 */
    void (*tcl_Release) (ClientData clientData); /* 216 */
    void (*tcl_ResetResult) (Tcl_Interp * interp); /* 217 */
    int (*tcl_ScanElement) (CONST char * str, int * flagPtr); /* 218 */






|







 







>
|







 







|







 







|







 







|







 







|







 







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
...
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
....
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
....
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
....
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
....
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
 *	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.142 2008/07/27 22:18:23 nijtmans Exp $
 */

#ifndef _TCLDECLS
#define _TCLDECLS

#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
................................................................................
/* 17 */
EXTERN Tcl_Obj *	Tcl_ConcatObj (int objc, Tcl_Obj *CONST objv[]);
#endif
#ifndef Tcl_ConvertToType_TCL_DECLARED
#define Tcl_ConvertToType_TCL_DECLARED
/* 18 */
EXTERN int		Tcl_ConvertToType (Tcl_Interp * interp, 
				Tcl_Obj * objPtr, 
				CONST86 Tcl_ObjType * typePtr);
#endif
#ifndef Tcl_DbDecrRefCount_TCL_DECLARED
#define Tcl_DbDecrRefCount_TCL_DECLARED
/* 19 */
EXTERN void		Tcl_DbDecrRefCount (Tcl_Obj * objPtr, 
				CONST char * file, int line);
#endif
................................................................................
/* 39 */
EXTERN int		Tcl_GetLongFromObj (Tcl_Interp * interp, 
				Tcl_Obj * objPtr, long * longPtr);
#endif
#ifndef Tcl_GetObjType_TCL_DECLARED
#define Tcl_GetObjType_TCL_DECLARED
/* 40 */
EXTERN CONST86_RETURN Tcl_ObjType * Tcl_GetObjType (CONST char * typeName);
#endif
#ifndef Tcl_GetStringFromObj_TCL_DECLARED
#define Tcl_GetStringFromObj_TCL_DECLARED
/* 41 */
EXTERN char *		Tcl_GetStringFromObj (Tcl_Obj * objPtr, 
				int * lengthPtr);
#endif
................................................................................
/* 210 */
EXTERN void		Tcl_RegisterChannel (Tcl_Interp * interp, 
				Tcl_Channel chan);
#endif
#ifndef Tcl_RegisterObjType_TCL_DECLARED
#define Tcl_RegisterObjType_TCL_DECLARED
/* 211 */
EXTERN void		Tcl_RegisterObjType (CONST86 Tcl_ObjType * typePtr);
#endif
#ifndef Tcl_RegExpCompile_TCL_DECLARED
#define Tcl_RegExpCompile_TCL_DECLARED
/* 212 */
EXTERN Tcl_RegExp	Tcl_RegExpCompile (Tcl_Interp * interp, 
				CONST char * pattern);
#endif
................................................................................
    void (*tcl_SetTimer) (CONST86 Tcl_Time * timePtr); /* 11 */
    void (*tcl_Sleep) (int ms); /* 12 */
    int (*tcl_WaitForEvent) (CONST86 Tcl_Time * timePtr); /* 13 */
    int (*tcl_AppendAllObjTypes) (Tcl_Interp * interp, Tcl_Obj * objPtr); /* 14 */
    void (*tcl_AppendStringsToObj) (Tcl_Obj * objPtr, ...); /* 15 */
    void (*tcl_AppendToObj) (Tcl_Obj* objPtr, CONST char* bytes, int length); /* 16 */
    Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *CONST objv[]); /* 17 */
    int (*tcl_ConvertToType) (Tcl_Interp * interp, Tcl_Obj * objPtr, CONST86 Tcl_ObjType * typePtr); /* 18 */
    void (*tcl_DbDecrRefCount) (Tcl_Obj * objPtr, CONST char * file, int line); /* 19 */
    void (*tcl_DbIncrRefCount) (Tcl_Obj * objPtr, CONST char * file, int line); /* 20 */
    int (*tcl_DbIsShared) (Tcl_Obj * objPtr, CONST char * file, int line); /* 21 */
    Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, CONST char * file, int line); /* 22 */
    Tcl_Obj * (*tcl_DbNewByteArrayObj) (CONST unsigned char * bytes, int length, CONST char * file, int line); /* 23 */
    Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, CONST char * file, int line); /* 24 */
    Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *CONST * objv, CONST char * file, int line); /* 25 */
................................................................................
    unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj * objPtr, int * lengthPtr); /* 33 */
    int (*tcl_GetDouble) (Tcl_Interp * interp, CONST char * src, double * doublePtr); /* 34 */
    int (*tcl_GetDoubleFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr); /* 35 */
    int (*tcl_GetIndexFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr); /* 36 */
    int (*tcl_GetInt) (Tcl_Interp * interp, CONST char * src, int * intPtr); /* 37 */
    int (*tcl_GetIntFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr); /* 38 */
    int (*tcl_GetLongFromObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr); /* 39 */
    CONST86_RETURN Tcl_ObjType * (*tcl_GetObjType) (CONST char * typeName); /* 40 */
    char * (*tcl_GetStringFromObj) (Tcl_Obj * objPtr, int * lengthPtr); /* 41 */
    void (*tcl_InvalidateStringRep) (Tcl_Obj * objPtr); /* 42 */
    int (*tcl_ListObjAppendList) (Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr); /* 43 */
    int (*tcl_ListObjAppendElement) (Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr); /* 44 */
    int (*tcl_ListObjGetElements) (Tcl_Interp * interp, Tcl_Obj * listPtr, int * objcPtr, Tcl_Obj *** objvPtr); /* 45 */
    int (*tcl_ListObjIndex) (Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj ** objPtrPtr); /* 46 */
    int (*tcl_ListObjLength) (Tcl_Interp * interp, Tcl_Obj * listPtr, int * lengthPtr); /* 47 */
................................................................................
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
    void (*tcl_ReapDetachedProcs) (void); /* 207 */
#endif /* MACOSX */
    int (*tcl_RecordAndEval) (Tcl_Interp * interp, CONST char * cmd, int flags); /* 208 */
    int (*tcl_RecordAndEvalObj) (Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags); /* 209 */
    void (*tcl_RegisterChannel) (Tcl_Interp * interp, Tcl_Channel chan); /* 210 */
    void (*tcl_RegisterObjType) (CONST86 Tcl_ObjType * typePtr); /* 211 */
    Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp * interp, CONST char * pattern); /* 212 */
    int (*tcl_RegExpExec) (Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * text, CONST char * start); /* 213 */
    int (*tcl_RegExpMatch) (Tcl_Interp * interp, CONST char * text, CONST char * pattern); /* 214 */
    void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr); /* 215 */
    void (*tcl_Release) (ClientData clientData); /* 216 */
    void (*tcl_ResetResult) (Tcl_Interp * interp); /* 217 */
    int (*tcl_ScanElement) (CONST char * str, int * flagPtr); /* 218 */

Changes to generic/tclOOMethod.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
 *	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.8 2008/07/18 23:29:44 msofer Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
    PMFrameData *fdPtr)		/* Place to store information about the call
				 * frame. */
{
    Tcl_Namespace *nsPtr = contextPtr->oPtr->namespacePtr;
    register int result;
    const char *namePtr;
    CallFrame **framePtrPtr = &fdPtr->framePtr;
    static Tcl_ObjType *byteCodeTypePtr = NULL;	/* HACK! */

    /*
     * Compute basic information on the basis of the type of method it is.
     */

    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	namePtr = "<constructor>";






|







 







|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
 *	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.9 2008/07/27 22:18:23 nijtmans Exp $
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"
................................................................................
    PMFrameData *fdPtr)		/* Place to store information about the call
				 * frame. */
{
    Tcl_Namespace *nsPtr = contextPtr->oPtr->namespacePtr;
    register int result;
    const char *namePtr;
    CallFrame **framePtrPtr = &fdPtr->framePtr;
    static const Tcl_ObjType *byteCodeTypePtr = NULL;	/* HACK! */

    /*
     * Compute basic information on the basis of the type of method it is.
     */

    if (contextPtr->callPtr->flags & CONSTRUCTOR) {
	namePtr = "<constructor>";

Changes to generic/tclObj.c.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
...
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
...
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
...
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
...
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
....
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
....
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
....
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
....
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
....
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
 * Copyright (c) 2001 by ActiveState Corporation.
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.141 2008/04/27 22:21:31 dkf Exp $
 */

#include "tclInt.h"
#include "tommath.h"
#include <float.h>
#include <math.h>

................................................................................
 *	type.
 *
 *--------------------------------------------------------------
 */

void
Tcl_RegisterObjType(
    Tcl_ObjType *typePtr)	/* Information about object type; storage must
				 * be statically allocated (must live
				 * forever). */
{
    int isNew;

    Tcl_MutexLock(&tableMutex);
    Tcl_SetHashValue(
................................................................................
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

Tcl_ObjType *
Tcl_GetObjType(
    const char *typeName)	/* Name of Tcl object type to look up. */
{
    register Tcl_HashEntry *hPtr;
    Tcl_ObjType *typePtr = NULL;

    Tcl_MutexLock(&tableMutex);
    hPtr = Tcl_FindHashEntry(&typeTable, typeName);
    if (hPtr != NULL) {
	typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
    }
    Tcl_MutexUnlock(&tableMutex);
    return typePtr;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *----------------------------------------------------------------------
 */

int
Tcl_ConvertToType(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* The object to convert. */
    Tcl_ObjType *typePtr)	/* The target type. */
{
    if (objPtr->typePtr == typePtr) {
	return TCL_OK;
    }

    /*
     * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form
................................................................................
 */

#ifdef TCL_MEM_DEBUG
void
TclFreeObj(
    register Tcl_Obj *objPtr)	/* The object to be freed. */
{
    register Tcl_ObjType *typePtr = objPtr->typePtr;

    /*
     * This macro declares a variable, so must come here...
     */

    ObjInitDeletionContext(context);

    if (objPtr->refCount < -1) {
	Tcl_Panic("Reference count for %lx was negative", objPtr);
    }

    /* Invalidate the string rep first so we can use the bytes value 
     * for our pointer chain, and signal an obj deletion (as opposed
     * to shimmering) with 'length == -1' */ 
    
    TclInvalidateStringRep(objPtr);
    objPtr->length = -1;

    if (ObjDeletePending(context)) {
	PushObjToDelete(context, objPtr);
    } else {
	TCL_DTRACE_OBJ_FREE(objPtr);
................................................................................
}
#else /* TCL_MEM_DEBUG */

void
TclFreeObj(
    register Tcl_Obj *objPtr)	/* The object to be freed. */
{
    /* Invalidate the string rep first so we can use the bytes value 
     * for our pointer chain, and signal an obj deletion (as opposed
     * to shimmering) with 'length == -1' */ 

    TclInvalidateStringRep(objPtr);
    objPtr->length = -1;
    
    if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
	/*
	 * objPtr can be freed safely, as it will not attempt to free any
	 * other objects: it will not cause recursive calls to this function.
	 */

	TCL_DTRACE_OBJ_FREE(objPtr);
................................................................................
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_DuplicateObj(
    register Tcl_Obj *objPtr)		/* The object to duplicate. */
{
    register Tcl_ObjType *typePtr = objPtr->typePtr;
    register Tcl_Obj *dupPtr;

    TclNewObj(dupPtr);

    if (objPtr->bytes == NULL) {
	dupPtr->bytes = NULL;
    } else if (objPtr->bytes != tclEmptyStringRep) {
................................................................................
     * the same address with the same command epoch. Note that fully qualified
     * names have a NULL refNsPtr, these checks needn't be made.
     *
     * Check also that the command's epoch is up to date, and that the command
     * is not deleted.
     *
     * If any check fails, then force another conversion to the command type,
     * to discard the old rep and create a new one.      
     */

    resPtr = objPtr->internalRep.twoPtrValue.ptr1;
    if ((objPtr->typePtr != &tclCmdNameType)
	    || (resPtr == NULL)
	    || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch)
	    || (interp != cmdPtr->nsPtr->interp)
	    || (cmdPtr->flags & CMD_IS_DELETED)
	    || ((resPtr->refNsPtr != NULL) && 
		     (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp))
			     != resPtr->refNsPtr)
		     || (resPtr->refNsId != refNsPtr->nsId)
		     || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch)))
	) {
	
	result = tclCmdNameType.setFromAnyProc(interp, objPtr);
	
	resPtr = objPtr->internalRep.twoPtrValue.ptr1;
	if ((result == TCL_OK) && resPtr) {
	    cmdPtr = resPtr->cmdPtr;
	} else {
	    cmdPtr = NULL;
	}
    }
    
    return (Tcl_Command) cmdPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclSetCmdNameObj --
................................................................................
    resPtr->cmdEpoch = cmdPtr->cmdEpoch;
    resPtr->refCount = 1;

    name = TclGetString(objPtr);
    if ((*name++ == ':') && (*name == ':')) {
	/*
	 * The name is fully qualified: set the referring namespace to
	 * NULL. 
	 */

	resPtr->refNsPtr = NULL;
    } else {
	/*
	 * Get the current namespace.
	 */

	currNsPtr = iPtr->varFramePtr->nsPtr;
	
	resPtr->refNsPtr = currNsPtr;
	resPtr->refNsId = currNsPtr->nsId;
	resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
    }

    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
................................................................................
	cmdPtr->refCount++;
	resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
	if ((objPtr->typePtr == &tclCmdNameType)
		&& resPtr && (resPtr->refCount == 1)) {
	    /*
	     * Reuse the old ResolvedCmdName struct instead of freeing it
	     */
	    
	    Command *oldCmdPtr = resPtr->cmdPtr;

	    if (--oldCmdPtr->refCount == 0) {
		TclCleanupCommandMacro(oldCmdPtr);
	    }
	} else {
	    TclFreeIntRep(objPtr);
................................................................................
	    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
	    objPtr->typePtr = &tclCmdNameType;
	}
	resPtr->cmdPtr = cmdPtr;
	resPtr->cmdEpoch = cmdPtr->cmdEpoch;
	if ((*name++ == ':') && (*name == ':')) {
	    /*
	     * The name is fully qualified: set the referring namespace to 
	     * NULL. 
	     */

	    resPtr->refNsPtr = NULL;
	} else {
	    /*
	     * Get the current namespace.
	     */

	    currNsPtr = iPtr->varFramePtr->nsPtr;
	    
	    resPtr->refNsPtr = currNsPtr;
	    resPtr->refNsId = currNsPtr->nsId;
	    resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
	}
    } else {
	TclFreeIntRep(objPtr);
	objPtr->internalRep.twoPtrValue.ptr1 = NULL;






|







 







|







 







|




|




|







 







|







 







|











|

|
|







 







|

|



|







 







|







 







|








|





|

|







|







 







|









|







 







|







 







|
|









|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
...
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
...
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
...
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
...
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
....
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
....
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
....
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
....
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
....
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
 * Copyright (c) 2001 by ActiveState Corporation.
 * Copyright (c) 2005 by Kevin B. Kenny.  All rights reserved.
 * Copyright (c) 2007 Daniel A. Steffen <[email protected]>
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclObj.c,v 1.142 2008/07/27 22:18:21 nijtmans Exp $
 */

#include "tclInt.h"
#include "tommath.h"
#include <float.h>
#include <math.h>

................................................................................
 *	type.
 *
 *--------------------------------------------------------------
 */

void
Tcl_RegisterObjType(
    const Tcl_ObjType *typePtr)	/* Information about object type; storage must
				 * be statically allocated (must live
				 * forever). */
{
    int isNew;

    Tcl_MutexLock(&tableMutex);
    Tcl_SetHashValue(
................................................................................
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

const Tcl_ObjType *
Tcl_GetObjType(
    const char *typeName)	/* Name of Tcl object type to look up. */
{
    register Tcl_HashEntry *hPtr;
    const Tcl_ObjType *typePtr = NULL;

    Tcl_MutexLock(&tableMutex);
    hPtr = Tcl_FindHashEntry(&typeTable, typeName);
    if (hPtr != NULL) {
	typePtr = (const Tcl_ObjType *) Tcl_GetHashValue(hPtr);
    }
    Tcl_MutexUnlock(&tableMutex);
    return typePtr;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
 *----------------------------------------------------------------------
 */

int
Tcl_ConvertToType(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    Tcl_Obj *objPtr,		/* The object to convert. */
    const Tcl_ObjType *typePtr)	/* The target type. */
{
    if (objPtr->typePtr == typePtr) {
	return TCL_OK;
    }

    /*
     * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form
................................................................................
 */

#ifdef TCL_MEM_DEBUG
void
TclFreeObj(
    register Tcl_Obj *objPtr)	/* The object to be freed. */
{
    register const Tcl_ObjType *typePtr = objPtr->typePtr;

    /*
     * This macro declares a variable, so must come here...
     */

    ObjInitDeletionContext(context);

    if (objPtr->refCount < -1) {
	Tcl_Panic("Reference count for %lx was negative", objPtr);
    }

    /* Invalidate the string rep first so we can use the bytes value
     * for our pointer chain, and signal an obj deletion (as opposed
     * to shimmering) with 'length == -1' */

    TclInvalidateStringRep(objPtr);
    objPtr->length = -1;

    if (ObjDeletePending(context)) {
	PushObjToDelete(context, objPtr);
    } else {
	TCL_DTRACE_OBJ_FREE(objPtr);
................................................................................
}
#else /* TCL_MEM_DEBUG */

void
TclFreeObj(
    register Tcl_Obj *objPtr)	/* The object to be freed. */
{
    /* Invalidate the string rep first so we can use the bytes value
     * for our pointer chain, and signal an obj deletion (as opposed
     * to shimmering) with 'length == -1' */

    TclInvalidateStringRep(objPtr);
    objPtr->length = -1;

    if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
	/*
	 * objPtr can be freed safely, as it will not attempt to free any
	 * other objects: it will not cause recursive calls to this function.
	 */

	TCL_DTRACE_OBJ_FREE(objPtr);
................................................................................
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_DuplicateObj(
    register Tcl_Obj *objPtr)		/* The object to duplicate. */
{
    register const Tcl_ObjType *typePtr = objPtr->typePtr;
    register Tcl_Obj *dupPtr;

    TclNewObj(dupPtr);

    if (objPtr->bytes == NULL) {
	dupPtr->bytes = NULL;
    } else if (objPtr->bytes != tclEmptyStringRep) {
................................................................................
     * the same address with the same command epoch. Note that fully qualified
     * names have a NULL refNsPtr, these checks needn't be made.
     *
     * Check also that the command's epoch is up to date, and that the command
     * is not deleted.
     *
     * If any check fails, then force another conversion to the command type,
     * to discard the old rep and create a new one.
     */

    resPtr = objPtr->internalRep.twoPtrValue.ptr1;
    if ((objPtr->typePtr != &tclCmdNameType)
	    || (resPtr == NULL)
	    || (cmdPtr = resPtr->cmdPtr, cmdPtr->cmdEpoch != resPtr->cmdEpoch)
	    || (interp != cmdPtr->nsPtr->interp)
	    || (cmdPtr->flags & CMD_IS_DELETED)
	    || ((resPtr->refNsPtr != NULL) &&
		     (((refNsPtr = (Namespace *) TclGetCurrentNamespace(interp))
			     != resPtr->refNsPtr)
		     || (resPtr->refNsId != refNsPtr->nsId)
		     || (resPtr->refNsCmdEpoch != refNsPtr->cmdRefEpoch)))
	) {

	result = tclCmdNameType.setFromAnyProc(interp, objPtr);

	resPtr = objPtr->internalRep.twoPtrValue.ptr1;
	if ((result == TCL_OK) && resPtr) {
	    cmdPtr = resPtr->cmdPtr;
	} else {
	    cmdPtr = NULL;
	}
    }

    return (Tcl_Command) cmdPtr;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclSetCmdNameObj --
................................................................................
    resPtr->cmdEpoch = cmdPtr->cmdEpoch;
    resPtr->refCount = 1;

    name = TclGetString(objPtr);
    if ((*name++ == ':') && (*name == ':')) {
	/*
	 * The name is fully qualified: set the referring namespace to
	 * NULL.
	 */

	resPtr->refNsPtr = NULL;
    } else {
	/*
	 * Get the current namespace.
	 */

	currNsPtr = iPtr->varFramePtr->nsPtr;

	resPtr->refNsPtr = currNsPtr;
	resPtr->refNsId = currNsPtr->nsId;
	resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
    }

    TclFreeIntRep(objPtr);
    objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
................................................................................
	cmdPtr->refCount++;
	resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
	if ((objPtr->typePtr == &tclCmdNameType)
		&& resPtr && (resPtr->refCount == 1)) {
	    /*
	     * Reuse the old ResolvedCmdName struct instead of freeing it
	     */

	    Command *oldCmdPtr = resPtr->cmdPtr;

	    if (--oldCmdPtr->refCount == 0) {
		TclCleanupCommandMacro(oldCmdPtr);
	    }
	} else {
	    TclFreeIntRep(objPtr);
................................................................................
	    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
	    objPtr->typePtr = &tclCmdNameType;
	}
	resPtr->cmdPtr = cmdPtr;
	resPtr->cmdEpoch = cmdPtr->cmdEpoch;
	if ((*name++ == ':') && (*name == ':')) {
	    /*
	     * The name is fully qualified: set the referring namespace to
	     * NULL.
	     */

	    resPtr->refNsPtr = NULL;
	} else {
	    /*
	     * Get the current namespace.
	     */

	    currNsPtr = iPtr->varFramePtr->nsPtr;

	    resPtr->refNsPtr = currNsPtr;
	    resPtr->refNsId = currNsPtr->nsId;
	    resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
	}
    } else {
	TclFreeIntRep(objPtr);
	objPtr->internalRep.twoPtrValue.ptr1 = NULL;

Changes to generic/tclTestObj.c.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2005 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: tclTestObj.c,v 1.23 2008/07/19 22:50:43 nijtmans Exp $
 */

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

/*
 * An array of Tcl_Obj pointers used in the commands that operate on or get
................................................................................
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int varIndex, destIndex, i;
    char *index, *subCmd, *string;
    Tcl_ObjType *targetType;

    if (objc < 2) {
	wrongNumArgs:
	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
	return TCL_ERROR;
    }







|







 







|







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
 * Copyright (c) 1999 by Scriptics Corporation.
 * Copyright (c) 2005 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: tclTestObj.c,v 1.24 2008/07/27 22:18:23 nijtmans Exp $
 */

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

/*
 * An array of Tcl_Obj pointers used in the commands that operate on or get
................................................................................
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int varIndex, destIndex, i;
    char *index, *subCmd, *string;
    const Tcl_ObjType *targetType;

    if (objc < 2) {
	wrongNumArgs:
	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
	return TCL_ERROR;
    }